perm filename SOPS08.PAS[S1,ALS] blob
sn#399902 filedate 1978-12-05 generic text, type C, neo UTF8
COMMENT ⊗ VALID 00062 PAGES
C REC PAGE DESCRIPTION
C00001 00001
C00010 00002 (*PROGRAM HEADER PAGE*)
C00013 00003 program SOPAIPILLA (INPUT*,OUTPUT,PRR) (*X10S1*)
C00015 00004 (* Compiler-option constants... *)
C00021 00005 (* Constants fixed by S1 architecture... *)
C00026 00006 type
C00052 00007 var
C00062 00008 (** ERROR_CLASS: ERREXIT ASSERT ERROR **)
C00079 00009 (** DEBUGGING_CLASS: PRINTSET PRINTMEMOREG PRINTDATUM PRINT_NESTITEM PRINT_MSTENTRY PRINTNXTINST PRINTNAM PRINTTYP PRINTINT **)
C00091 00010 (** S1WORD_PROCESSOR_CLASS: NEWCODEREC GETFIELD GETSIGNEDFIELD PUTFIELD **)
C00098 00011 (** S1WORD_PROCESSOR_CLASS: REAL_TO_S1WORD ZSYMBOL_TO_S1WORDS INTEGER_TO_S1WORD SETREP_TO_S1WORDS **)
C00108 00012 (** MISCELLANEOUS_CLASS: LABELHASH LABELNUMBER MIN MAX POWER2 FLDW CVOS_S1WORD_12 CVOS_12 CVOS_10 CSP_HASH OPC_HASH NAME_TO_CSP MNEM_TO_OPC **)
C00116 00013 (** INSTRUCTION_PROCESSOR_CLASS: PTR_OPNDXWD S1OPNDS_EQUAL S1OPND_TEMPLOC GETS1OPCODE AFTER_LAST_XWORD JUMPSKIPDEST NEXT_INSTRUCTION AFTER_FAKEOPS INVERT_SKIP **)
C00127 00014 (** FIXUP_CLASS: FIXSOP FIXJOP FIXOPND2 **)
C00132 00015 (** FIXUP_CLASS: ADD_CODEPTR_TO_CODELIST ADD_JUMPLIST_PLUS_ONE ADD_JUMP_TO_JUMPLIST JUMP_TO_TABLE_RECORD_OR_FIX JUMP_TO_LABEL_RECORD_OR_FIX OPND2_RECORD_OR_FIX **)
C00138 00016 (** OPERAND_PROCESSOR_CLASS: ISREG IS_T_REG IS_T_REG_NOT_RT ISSHORTCONST ISCONST EQUAL_OPERANDS REG_OPERAND IMM_OPERAND REAL_IMM_OPERAND IS_RT IS_RTA IS_RTB USES_RTA USES_RTB **)
C00147 00017 (** OPERAND_PROCESSOR_CLASS: EXTENDED_IMM_OPERAND REGDISP_OPERAND EXTENDED_REGDISP_OPERAND EXT_REGADDR_OPERAND ADDR_OPERAND **)
C00151 00018 (** REGISTER/GLOBAL_MANAGEMENT_CLASS: ALLOCGBL FREEGBL_S ALLOCRG ALLOCRP FREERG_S FINDRP FINDRG MOVE_AND_FREE_RTB CURRENT_PARMREG_COUNT IS_PARMREG CHECK_DSP_TMP_COLLISION RESERVE_PARMREGS **)
C00161 00019 (** REGISTER/GLOBAL_MANAGEMENT_CLASS: FREEDATUMREGS FREEREGSBUTONE FREERGSBUTSOME FREEVPAREG FREEVPARGUNLESS FREE_TEMP_REGS **)
C00169 00020 (** CODE_EMITTER_CLASS: BUILD_CW_OPERAND EMIT_INSTR_OPNDS INSERT_INSTR_OPNDS **)
C00177 00021 (** CODE_EMITTER_CLASS: EMITFAKEINST INSERTSOP INSERTJOP INSERTXOP EMIT_S1WORD EMIT_ZEROS1WORD **)
C00184 00022 (** CODE_EMITTER_CLASS: EMITSOP EMITJOP EMITTOP EMITXOP ALLOC_AND_EMIT_TOP **)
C00193 00023 (** DATUM_PROCESSOR_CLASS: REG_DATUM COERCE_DATUM COERCE_TWO_DATUMS DATUM_IS_REG DATUM_IS_T_REG DATUM_IS_FILADR LOADSTACKEXCEPT BJUMP_TO_BINTVAL INCREMENT_DATUM **)
C00210 00024 (** DATUM_PROCESSOR_CLASS: BINTVAL_TO_BJUMP PARMREG_TO_PARMSAVE TRANSLATE_LVLDSP **)
C00216 00025 (** DATUM_PROCESSOR_CLASS: IS_SIMPLE FITS_SHRT_OFFSET FITS_SHORT_INDEX IS_CONSTANT IS_CONST_PLUS_OPND PUSHTOP POPTOP **)
C00221 00026 (** LITERAL_TABLE_CLASS: UPD_REALTBL UPD_SETTBL UPD_PROCTBL **)
C00225 00027 (** LITERAL_TABLE_CLASS: UPD_LBLTBL UPD_BOUNDTBL **)
C00229 00028 (** GET_OPERAND_CLASS: INSERT_SHORT_VPA VPA_OPERAND_NOSHIFT FIT_IN_OPERAND **)
C00238 00029 (** GET_OPERAND_CLASS: FIT_ADDRESS_IN_OPERAND **)
C00243 00030 (** GET_OPERAND_CLASS: GET_OPERAND GET_SHORT_OPERAND GET_ADDRESS **)
C00246 00031 (** GET_OPERAND_CLASS: MOVE_QUANTITY SLR_QUANTITY COERCE_AND_MOVE_QUANTITY STORE **)
C00253 00032 (** SIMPLIFY_CLASS: ADD_SUB_SINGLE INC_OR_DEC ADD_TOP_TWO_DATUMS MULT_SINGLE SIMPLIFY ADD_VPAS FPA_LVL_PLUS_VPA1 FPA_DSPLMT_PLUS_VPA1 VPA_FPA_FINALIND SHORT_AND_REG CALCULATE_FPA DEREF_AND_SHIFT SHIFT_VPA1 DEREF DEREF_TO_END **)
C00285 00033 (** DISASSEMBLE_CLASS: DISASSEMBLE PRINTLOC PRINTIWORD PRINTXWRD1 PRINTXWRD2 PRINTOPCODE PRINTOPERAND PRINTREG PRINTSHORTOP **)
C00301 00034 (** OBJECT_MODULE_SEGMENT_CLASS: CODE_CONCRETIZER INSTR_WORDS **)
C00306 00035 (** OBJECT_MODULE_SEGMENT_CLASS: CONC_PASS1 INSERT_S1LOC JMPX_TO_JMPA_OPT **)
C00312 00036 (** OBJECT_MODULE_SEGMENT_CLASS: PEEPHOLE_OPTIMIZER DELETE_INSTR SKIP_JMPA_OPT COLLAPSE_MOV_OPT **)
C00330 00037 (** OBJECT_MODULE_SEGMENT_CLASS: CONC_PASS2 **)
C00332 00038 (** OBJECT_MODULE_SEGMENT_CLASS: CONC_PASS3 PASS3XWORDFIX INSERT_NOP **)
C00352 00039 (** OBJECT_MODULE_SEGMENT_CLASS: INIT_SEGMENT GEN_SEGMENT FIXDISP OPEN_SEGMENT CLOSE_SEGMENT CLEAROUT_TXTBUF OPEN_TXT CLOSE_TXT OUT_TXT **)
C00360 00040 (** OBJECT_MODULE_SEGMENT_CLASS: OPEN_SEG CLOSE_SEG OUT_SEG OPEN_ESD CLOSE_ESD OUT_ESD OPEN_ESR CLOSE_ESR OUT_ESR OPEN_RLD CLOSE_RLD OUT_RLD **)
C00367 00041 (** OBJECT_MODULE_SEGMENT_CLASS **)
C00373 00042 (** OBJECT_MODULE_SEGMENT_CLASS **)
C00380 00043 (** CALLSTANDARD_CLASS: SAVE_PARMREGS RESTORE_PARMREGS CALLSTANDARD GENCALL ONE_ARG TWO_SINGLE_ARGS CHECKFILADR ALLOC_EXCESS EXCESS_ARG DEALLOC_EXCESS CHECK_REF_PARM RESULT_PARM **)
C00402 00044 (** ASMNXTINST_CLASS: ASMNXTINST CASE1 **)
C00411 00045 (** ASMNXTINST_CLASS: CASE2 **)
C00420 00046 (** ASMNXTINST_CLASS: CASE3 **)
C00428 00047 (** ASMNXTINNT_CLASS: CASE4 CASE5 **)
C00444 00048 (** ASMNXTINST_CLASS: CASE6 CASE7 **)
C00462 00049 (** ASMNXTINST_CLASS: CASE8 **)
C00481 00050 (** ASMNXTINST_CLASS: CASE9 **)
C00494 00051 (** ASMNXTINST_CLASS: CASE10 **)
C00505 00052 (** ASMNXTINST_CLASS: **)
C00514 00053 (** READNXTINST_CLASS: READNXTINST READNAM READTYP READINT READREAL READSET READSET **)
C00523 00054 (** INITIALIZE_CLASS: INITIALIZE ENTER_OPC ENTER_CSP INIT1 **)
C00544 00055 (** INITIALIZE_CLASS: INIT2 **)
C00557 00056 (** INITIALIZE_CLASS: INIT3 **)
C00577 00057 (** INITIALIZE_CLASS: INIT4 **)
C00611 00058 (** INITIALIZE_CLASS: INIT5 **)
C00633 00059 (** INITIALIZE_CLASS: INIT6 **)
C00638 00060 (** INITIALIZE_CLASS: INIT7 **)
C00659 00061 (** INITIALIZE_CLASS: **)
C00660 00062 (** MAIN_PROGRAM: **)
C00665 ENDMK
C⊗;
(*PROGRAM HEADER PAGE*)
(*PAS10 OPTIONS*) (*$D+,R32,S1300*) (*X10S1*)
(* DEFAULT
D+ DEBUG AND POSTMORTEM DUMP -
E+ EXTERNAL CALLS TO LEVEL 1 PROCEDURES ALLOWED -
Fn FILE OPTION 1
I+ FORTRAN I/O IN EXTERNAL FORTRAN SUBROUTINES -
L+ OBJECT LISTING -
Rn SIZE OF LOW-SEGMENT (SEE PAS10 MANUAL)
Sn MAX INSTRUCTIONS PER STATEMENT 1000
T+ RUNTIME CHECK +
U+ 72 COLUMN FORMAT -
Xn HIGHEST REGISTER FOR PARAMETERS 6
*)
(*SLAC PCPASC OPTIONS*) (* B+,D+,M-*)
(* DEFAULT
A+ GENERATE 370 OBJECT MODULE -
A- GENERATE 370 ASSEMBLY MODULE
B+ BOUNDS CHECKING, BUT ALLOW 'BIG' CHARACTERS -
C+ EMIT PCODE +
D+ RUNTIME CHECKING OF POINTER, INDEX, SUBRANGE VALUES -
E+ FILE IS IN EBCDIC CHARACTER SET -
F+ SAVE FPR'S ON PROCEDURE/FUNCTION ENTRY +
K+ ENABLE STATEMENT EXECUTION COUNTING -
L+ LIST SOURCE PROGRAM +
M+ 72 COLUMN FORMAT +
P+ DOUBLE-WORD BOUNDARY ALIGNMENT -
S+ SAVE GPR'S ON PROCEDURE/FUNCTION ENTRY +
T+ PRINT SYMBOL TABLES (FOR POST-PROCESSOR) -
U+ GET STATISTICS?? 2ND PARAMETER TO PCODE BGN INSTR. -
V+ ?? 3RD PCODE BGN INSTRUCTION PARAMETER -
X+ USE ACTUAL PROCEDURE NAMES FOR EXTERNAL REFERENCES -
X- GENERATE UNIQUE 8-CHAR NAMES FOR EXTERNAL REFERENCES
*)
(*S1 PCPASC OPTION DIFFERENCES*) (* A+,B+,D+,M120*) (*X10S1*)
(* DEFAULT
A+ GENERATE S1 ASSEMBLY MODULE -
A- GENERATE S1 OBJECT MODULE
*)
(* SLAC/PDP-10 TRANSPORT DEPENDENCIES FLAGGED WITH "XSL10" *)
(* PDP-10/S-1 TRANSPORT DEPENDENCIES FLAGGED WITH "X10S1" *)
program SOPAIPILLA (INPUT*,OUTPUT,PRR); (*X10S1*)
(*program SOPAIPILLA (INPUT,OUTPUT,PRR);*) (*X10S1*)
(*SOPAIPILLA - Stanford Optimizing Packed-Address Implementation of a
Pcode Intermediate Language Logical Assembler*)
(*CAVEAT : This is a preliminary version of this program. It should not
be considered in any sense in final form, since it is undergoing daily
development and modification.*)
(*This program translates P-Code, an intermediate language invented as a
target language of a PASCAL compiler, into S-1 machine language. During
the translation process, a number of local optimizations are performed. A
detailed description of the logic of the program, including discussion of
the optimizations performed is contained in the document SOPADOPE*)
(*SOPAIPILLA was written during summer 1977 by Erik J. Gilbert and David
W. Wall of the Computer Science Department at Stanford University. Much
of its internal philosophy is based on a similar compiler for the IBM 370
written by Sassan Hazeghi, also of the Stanford C.S. Dept.*)
(* Compiler-option constants... *)
const
CHARDIF = 40B; (*CHARDIF*) (*X10S1*)
(*CHARDIF = 0; *) (*CHARDIF*) (*X10S1*)
(* LCW 2AUG78
This compiler will not compile programs containing constants outside the
range of MIN_ON_COMP_MACH..MAX_ON_COMP_MACH. Furthermore,
MAX_ON_COMP_MACH and MIN_ON_COMP_MACH must be set to the minimum and
maximum values, respectively, of integers of the machine on which this
compiler runs. BITS_ON_COMP_MACH must be set to the number of bits in
an integer of the machine on which the compiler runs. However, when
running the compiler on a machine with a word size larger than that of
the S1, these constants must be set as if that machine had a word size
equal to that of the S1. Never try to run this program on a machine with
word length less than 32.
*)
(*MAX_ON_COMP_MACH = 2147483647; " 2**31 - 1 (370) " *)
(*MIN_ON_COMP_MACH = -2147483648; " -2**31 (370) " *)
(*BITS_ON_COMP_MACH = 32; " 370 " *)
(*MAX_EXP_ON_COMP_MACH = 30; " two less than bits " *)
MAX_ON_COMP_MACH = 34359738367; " 2**35 - 1 (10/S1) "
MIN_ON_COMP_MACH = -34359738367; " -2**35 (10/S1) "
(* MIN_ON_COMP_MACH should be one less, but runtime won't accept it ... *)
BITS_ON_COMP_MACH = 36; " 10/S1 "
MAX_EXP_ON_COMP_MACH = 34; " two less than bits "
BLKMOV_THRESH = 225; (*PMOVs of >= 225 QWs generate BLKMOV*)
(*Everything < 225 QWs can be done with
at most 3 MOVMQs or 2 MOVMSs*)
MINPARS1REG = 8; (*smallest numbered parameter register*)
MAXDSPS1REG = 29; (*largest numbered display register*)
MAXPAREG = 10; (*Maximum number of parameter registers*)
MAXPAREGM1 = 9; (*Maximum logical index of a parameter reg*)
MAXLVL = 8; (*Maximum nesting of procedure declarations*)
MAXLBL = 99999; (*Maximum label integer*)
MAXCODEW = 999999; (*Maximum number of words in a CODEREC*)
STRINGMAX = 150; (*Maximum length of a string*)
SEG_START_RELPC = 0; (*Relative PC of segment start*)
SEG_EP_DISP = 16; (*Storage units from seg start to entry point*)
TMPDATAWORDSGUESS = 3;
SFLDMAX = 3; (*VPA shift maximum*)
NILVAL = -1;
MAXPEEP_PASSES = 2; (*Maximum number of passes in PEEPHOLE_OPTIMIZER*) (*PTZ*)
MINSTKINX = -1;
TMPD1 = -1; (*TMPD1 is used to hold synthetic DATUMs*)
BOT = 1; (*STKINX of the first datum on STK*)
MAXSTKINX = 30;
MAXMST = 15; (*Maximum nesting of function calls*)
MAXESDINDEX = 1000;
MAXESRINDEX = 1000;
MAXZINDEX = 1000; (*max of two above*)
LBLHTSIZE = 197; (*prime*)
LBLHTSIZEM1 = 196;
CSPHTSIZE = 91; (*prime*)
CSPHTSIZEM1 = 90;
OPCHTSIZE = 197; (*prime*)
OPCHTSIZEM1 = 196;
(*370 values for 4 constants ... *)
(*
LCAFTMST = 80;
FNCRSLT = 72;
LASTFILBUF = 280;
L1LOCALDATATRANSLATION = 408; "*LASTFILBUF - MINSHORTOFFSET*WORDUNITS*"
*)
(*S1 valuesfor 4 constants ... *)
LCAFTMST = 8;
FNCRSLT = 0;
LASTFILBUF = 44; (*level 1 dsplmt of first local variable,
which is after level 1 MST part.*)
L1LOCALDATATRANSLATION = 172; (*LASTFILBUF - MINSHORTOFFSET*WORDUNITS*)
LCIOFILADR = 8; (*level 1 dspl of the global variable used
to store current I/O file addr*)
(* ...end compiler-option constants *)
(* Constants fixed by S1 architecture... *)
FIRSTS1REG = 0;
S1RCPL = 0; (*register to start CPL block-descriptor*)
S1R0 = 0;
S1RPC = 3;
S1RTA = 4;
S1RTB = 6;
S1RSP = 30; (*stack-pointer register*)
S1RNP = 31; (*heap-pointer register*)
LASTS1REG = 31;
S1RNPMEMADR = 124; (*memory address of S1RNP*) (*BNDTRPKLU*)
FIRSTS1GBL = 32; (*globals are low-core memory words*)
S1GMEMEND = 32; (*runtime sets up address of last QW of heap here*)
S1GSEGBASE = 33; (*global number of segment base for trace*)
S1GBLZ = 34; (*global number of zero word for block descriptor use*)
S1GCPLPL = 35; (*global number of CPLPL block-descriptor*)
LASTS1GBL = 39; (*number of last S1 low-core global*)
MAXS1ADDR = 1073741823; (*2**30 - 1*) (*EJG*)
MINS1DISP = -16777216; (*-2**24*)
MAXS1DISP = 16777215; (*2**24 - 1*)
MINSIGNEDS1ADDR = -536870912; (*-2**29*)
MAXSIGNEDS1ADDR = 536870911; (*2**29-1*)
MINSHORTOFFSET = -32;
MAXSHORTOFFSET = 31;
MINSHORTCONSTANT = -32;
MAXSHORTCONSTANT = 31;
MAXINDEXSHIFT = 3;
MINJPROFFSET = -2048;
MAXJPROFFSET = 2047;
MINSKPOFFSET = -8;
MAXSKPOFFSET = 7;
MAXMOVMQ = 32; (*64 and 128 are handled specially*)
(*MAXMOVMQ must be a multiple of WORDUNITS*)
MAXMOVMS = 32; (*5DEC78 ALS*)
S1TRUEFLAG = -1;
DALIGNSHIFT = 3;
DALIGNMUL = 8;
CHARBITS = 9;
WORDBITS = 36;
WORDCHARS = 4;
QUARTERWORDUNITS = 1;
HALFWORDUNITS = 2;
WORDUNITS = 4;
DOUBLEWORDUNITS = 8;
PAGEUNITS = 2048;
MAXALIGNBOUNDARY = 4;
MAXSETEL = 63; (*Change this when we do 4-word sets.*)
OPCODE_START = 0; OPCODE_LEN = 12;
OPND1_START = 12; OPND1_LEN = 12;
OPND2_START = 24; OPND2_LEN = 12;
T_START = 10; T_LEN = 2;
PR_START = 11; PR_LEN = 1;
SKP_START = 8; SKP_LEN = 4;
J_START = 24; J_LEN = 12;
FAKEOPND_START = 12; FAKEOPND_LEN = 24;
OPND_START = 0; OPND_LEN = 12; (*PTZ*)
OPNDX_START = 0; OPNDX_LEN = 1;
OPNDREG_START = 1; OPNDREG_LEN = 5;
OPNDF_START = 6; OPNDF_LEN = 6;
OPND1X_START = 12; OPND1X_LEN = 1;
OPND1REG_START = 13; OPND1REG_LEN = 5;
OPND1F_START = 18; OPND1F_LEN = 6;
OPND2X_START = 24; OPND2X_LEN = 1;
OPND2REG_START = 25; OPND2REG_LEN = 5;
OPND2F_START = 30; OPND2F_LEN = 6;
XWP_START = 0; XWP_LEN = 1;
XWV_START = 1; XWV_LEN = 1;
XWD_START = 2; XWD_LEN = 1;
XWI_START = 3; XWI_LEN = 1;
XWS_START = 4; XWS_LEN = 2;
XWADDR_START = 6; XWADDR_LEN = 30;
XWREG_START = 6; XWREG_LEN = 5;
XWDISP_START = 11; XWDISP_LEN = 25;
BNDTYP_START = 0; BNDTYP_LEN = 9;
RGS = 0; MEM = 1; (*should be enum. type, but alignment*)
(* ...end constants fixed by S1 architecture *)
type
ERRORCODE = (
WABR_OR_NGR_OF_NONREAL,
WADDR_OUT_OF_RANGE,
WADDRESS_CHECK_ON_NONADDRESS,
WALIGNMENT_ERROR,
WANDOR_NEEDS_BOOLEAN,
WBINARY_OPND_TYPE_CONFLICT,
WCHECKED_CONSTANT_OUT_OF_RANGE,
WCHECKING_INVALID_TYPE,
WCHR_NEEDS_INT,
WCOERCION_INVALID,
WCOMPARE_ILLEGAL,
WCOMPM_NEEDS_ADDR,
WDISP_OUT_OF_RANGE,
WEXPR_TOO_COMPLEX,
WFILE_ADDRESS_NEEDED,
WFJP_NEEDS_BOOLEAN,
WFJP_WITH_NONEMPTY_STACK,
WFLOAT_OF_INVALID_TYPE,
WFUNC_CALLS_NESTED_TOO_DEEPLY,
WINCOMPATIBLE_TYPES,
WINDEX_WITHOUT_BASE,
WINDEXING_IN_PARMS,
WINN_REQUIRES_SET_ON_TOP_OF_STACK,
WINSTR_TYPE_NOT_DATUM_TYPE,
WINSUFF_PARMS_SPECIFIED,
WINTEGER_CONSTANT_DIV_MOD_BY_ZERO,
WINVAL_CSP,
WINVAL_OPC,
WINVAL_TRACE,
WINVAL_TYP_ON_LDC,
WINVALID_DISPLACEMENT,
WINVALID_IMPLICIT_TYPE_COERCION,
WINVALID_LEVEL,
WINVALID_TYPE_CODE,
WIXA_NEEDS_ADDR,
WL_LPTR_LBLNUM_UNDEFINED,
WLAST_SST_PARM_TOO_BIG,
WLOADING_STRING,
WMOV_NEEDS_ADDRS,
WMST_SPECIFIED_INSUFF_PARM_STORAGE,
WMST_WITHOUT_CUP_IN_LAST_SEGMENT,
WMULT_DEFINED_LAB,
WNESTING_TOO_DEEP_OR_EXPRESSION_TOO_COMPLEX,
WNEW_MUST_HAVE_ADDR_AND_INT,
WNOT_AN_ADDR,
WNOT_DISCRETE_TYPE,
WNOT_NEEDS_BOOLEAN,
WNULLREF,
WODD_REQUIRES_AN_INTEGER,
WORD_NEEDS_INT_BOOLEAN_OR_CHAR,
WPOP_OF_EMPTY_STACK,
WREAL_CONSTANT_DIVISION_BY_ZERO,
WREGPARMS_SPEC_TOO_LOW_IN_MST,
WRST_NEEDS_ADDR,
WSAV_NEEDS_ADDR,
WSET_OPERATION_ON_NONSET_TYPES,
WSGS_OR_INN_REQUIRES_INT_CHAR_OR_BOOLEAN,
WSIO_DIDNT_SEE_FILEADDR,
WSIO_WITH_NONADDRESS,
WSQUARE_OF_INVALID_TYPE,
WSST_AND_ENT_INCONSISTENT,
WSST_AND_RET_INCONSISTENT,
WSTACK_LEFT_NONEMPTY_IN_LAST_SEGMENT,
WSTACK_NON_EMPTY,
WSTACK_NOT_SINGLE,
WTRUNCATE_OF_INVALID_TYPE,
WUJP_WITH_NONEMPTY_STACK,
WWRONG_COMPARE,
WXJP_WITHOUT_SINGLETON_STACK);
P_OPCODE = (
PABI, PABR, PADI, PAND, PBGN, PCHK, PCHR, PCSP,
PCUP, PDEC, PDEF, PDIF, PDVI, PENT, PEOF, PFJP,
PFLO, PFLT, PINC, PIND, PINN, PINT, PIOR, PIXA,
PLAB, PLAO, PLCA, PLDA, PLDC, PLDO, PLOC, PLOD,
PMOD, PMOV, PMPI, PMST, PNEW, PNGI, PNGR, PNOT,
PODD, PORD, PPAR, PPRE, PRET, PRST, PSAV, PSBI,
PSGS, PSQI, PSQR, PSRO, PSST, PSTO, PSTP, PSTR,
PSUC, PTOF, PTON, PTRC, PUJP, PUNI, PXJP, PADR,
PSBR, PMPR, PDVR, PEQU, PNEQ, PGEQ, PGRT, PLEQ,
PLES);
P_STANDARDPROC = (
QATN, QCLK, QCOS, QEIO, QELN, QEOF, QEXP, QGET, QLOG, QNEW,
QPUT, QRDB, QRDC, QRDI, QRDR, QRDS, QRES, QREW, QRLN, QRST,
QSAV, QSIN, QSIO, QSQT, QTRP, QWLN, QWRB, QWRC, QWRI, QWRR,
QWRS, QXIT);
S1OPCODE = (
XILLEGAL,
XPLOC,
XS1LOC,
XFREEREG, (*PBK*)
XABS_Q,
XABS_H,
XABS_S,
XABS_D,
XADD_S,
XADD_D,
XADJSP_UP,
XADJSP_DN,
XALLOC_1,
XAND_Q,
XAND_D,
XAND_TC_D,
XAND_CT_D,
XBLCMP_EQL_Q,
XBLCMP_NEQ_Q,
XBLCMP_GEQ_Q,
XBLCMP_GTR_Q,
XBLCMP_LEQ_Q,
XBLCMP_LSS_Q,
XBLKMOV,
XBTRP_B_Q,
XBTRP_B_H,
XBTRP_B_S,
XBTRP_B_D,
XBTRP_M1_Q,
XBTRP_M1_H,
XBTRP_M1_S,
XBTRP_M1_D,
XBTRP_0_Q,
XBTRP_0_H,
XBTRP_0_S,
XBTRP_0_D,
XBTRP_1_Q,
XBTRP_1_H,
XBTRP_1_S,
XBTRP_1_D,
XDEC_S,
XFX_DM_S_S,
XFX_DM_S_D,
XFLOAT_S_Q,
XFLOAT_S_H,
XFLOAT_S_S,
XFLOAT_S_D,
XFADD_S,
XFADD_D,
XFSUB_S,
XFSUBV_S,
XFSUB_D,
XFSUBV_D,
XFMULT_S,
XFMULT_D,
XFDIV_S,
XFDIVV_S,
XFDIV_D,
XFDIVV_D,
XFTRANS_S_D,
XFTRANS_D_S,
XHALT, (*BNDTRPKLU*)
XINC_S,
XJMPA,
XJMPZ_EQL_Q,
XJSR,
XMOV_A,
XMOV_Q_Q,
XMOV_Q_H,
XMOV_H_Q,
XMOV_H_H,
XMOV_Q_S,
XMOV_H_S,
XMOV_S_Q,
XMOV_S_H,
XMOV_S_S,
XMOV_Q_D,
XMOV_H_D,
XMOV_S_D,
XMOV_D_Q,
XMOV_D_H,
XMOV_D_S,
XMOV_D_D,
XMOVMQ_2,
XMOVMQ_3,
XMOVMQ_4,
XMOVMQ_5,
XMOVMQ_6,
XMOVMQ_7,
XMOVMQ_8,
XMOVMQ_9,
XMOVMQ_10,
XMOVMQ_11,
XMOVMQ_12,
XMOVMQ_13,
XMOVMQ_14,
XMOVMQ_15,
XMOVMQ_16,
XMOVMQ_17,
XMOVMQ_18,
XMOVMQ_19,
XMOVMQ_20,
XMOVMQ_21,
XMOVMQ_22,
XMOVMQ_23,
XMOVMQ_24,
XMOVMQ_25,
XMOVMQ_26,
XMOVMQ_27,
XMOVMQ_28,
XMOVMQ_29,
XMOVMQ_30,
XMOVMQ_31,
XMOVMQ_32,
XMOVMQ_64,
XMOVMQ_128,
XMOVMS_2, (*through MOVMS_32 added 5/dec/78 ALS*)
XMOVMS_3,
XMOVMS_4,
XMOVMS_5,
XMOVMS_6,
XMOVMS_7,
XMOVMS_8,
XMOVMS_9,
XMOVMS_10,
XMOVMS_11,
XMOVMS_12,
XMOVMS_13,
XMOVMS_14,
XMOVMS_15,
XMOVMS_16,
XMOVMS_17,
XMOVMS_18,
XMOVMS_19,
XMOVMS_20,
XMOVMS_21,
XMOVMS_22,
XMOVMS_23,
XMOVMS_24,
XMOVMS_25,
XMOVMS_26,
XMOVMS_27,
XMOVMS_28,
XMOVMS_29,
XMOVMS_30,
XMOVMS_31,
XMOVMS_32,
XMULT_S,
XMULT_D,
XNEG_Q,
XNEG_H,
XNEG_S,
XNEG_D,
XNOP,
XOR_Q,
XOR_D,
XQUO_S,
XQUOV_S,
XQUO_D,
XQUOV_D,
XREM_S,
XREMV_S,
XREM_D,
XREMV_D,
XRETSR,
XSHF_LF_D,
XSHFV_LF_D,
XSHFA_LF_S,
XSHFAV_LF_S,
XSKP_EQL_Q, (*Start of S1SKIPOPCODE subrange*)
XSKP_NEQ_Q,
XSKP_GEQ_Q,
XSKP_GTR_Q,
XSKP_LEQ_Q,
XSKP_LSS_Q,
XSKP_EQL_H,
XSKP_NEQ_H,
XSKP_GEQ_H,
XSKP_GTR_H,
XSKP_LEQ_H,
XSKP_LSS_H,
XSKP_EQL_S,
XSKP_NEQ_S,
XSKP_GEQ_S,
XSKP_GTR_S,
XSKP_LEQ_S,
XSKP_LSS_S,
XSKP_EQL_D,
XSKP_NEQ_D,
XSKP_GEQ_D,
XSKP_GTR_D,
XSKP_LEQ_D,
XSKP_LSS_D,
XSKP_NON_Q,
XSKP_NON_H,
XSKP_NON_S,
XSKP_NON_D,
XSKP_ANY_Q,
XSKP_ANY_H,
XSKP_ANY_S,
XSKP_ANY_D, (*End of S1SKIPOPCODE subrange*)
XSLR_0,
XSLR_1,
XSLR_2,
XSLR_3,
XSLR_4,
XSLR_5,
XSLR_6,
XSLR_7,
XSLR_8,
XSLR_9,
XSLR_10,
XSLR_11,
XSLR_12,
XSLR_13,
XSLR_14,
XSLR_15,
XSLR_16,
XSLR_17,
XSLR_18,
XSLR_19,
XSLR_20,
XSLR_21,
XSLR_22,
XSLR_23,
XSLR_24,
XSLR_25,
XSLR_26,
XSLR_27,
XSLR_28,
XSLR_29,
XSLR_30,
XSLR_31,
XSLRADR_0,
XSLRADR_1,
XSLRADR_2,
XSLRADR_3,
XSLRADR_4,
XSLRADR_5,
XSLRADR_6,
XSLRADR_7,
XSLRADR_8,
XSLRADR_9,
XSLRADR_10,
XSLRADR_11,
XSLRADR_12,
XSLRADR_13,
XSLRADR_14,
XSLRADR_15,
XSLRADR_16,
XSLRADR_17,
XSLRADR_18,
XSLRADR_19,
XSLRADR_20,
XSLRADR_21,
XSLRADR_22,
XSLRADR_23,
XSLRADR_24,
XSLRADR_25,
XSLRADR_26,
XSLRADR_27,
XSLRADR_28,
XSLRADR_29,
XSLRADR_30,
XSLRADR_31,
XSUB_S,
XSUBV_S,
XSUB_D,
XSUBV_D,
XTRANS_Q_Q,
XTRANS_Q_H,
XTRANS_H_Q,
XTRANS_H_H,
XTRANS_Q_S,
XTRANS_H_S,
XTRANS_S_Q,
XTRANS_S_H,
XTRANS_S_S,
XTRANS_Q_D,
XTRANS_H_D,
XTRANS_S_D,
XTRANS_D_Q,
XTRANS_D_H,
XTRANS_D_S,
XTRANS_D_D,
XXOR_Q);
HARDS1OPCODE = 0..4095;
S1SKIPOPCODE = XSKP_EQL_Q..XSKP_ANY_D;
OPNDTYPE = (ILLARITH, ILLCOMP,
TYPA, TYPM, TYPN, TYPB, TYPC, TYPS, TYPQ,
TYPH, TYPI, TYPD, TYPX, TYPR, TYPP, TYPJ);
S1PRECISION = (S1ILLEGAL, S1Q, S1H, S1S, S1D);
S1LENGTH = 0..8; (*QW LENGTH OF A BASIC S1 PRECISION*)
S1OPFORMAT = (VFAKEOP, VTOP, VJOP, VXOP, VSOP);
ALIGNMENTBOUNDARY = 0..MAXALIGNBOUNDARY;
S1REGISTER = FIRSTS1REG..LASTS1REG;
S1GBL = FIRSTS1GBL..LASTS1GBL;
S1ADDRESS = 0..MAXS1ADDR;
S1DISP = MINS1DISP..MAXS1DISP;
S1BITNUM = 0..35;
S1SKIPDISTANCE = MINSKPOFFSET..MAXSKPOFFSET;
BIT = 0..1;
TWOBITS = 0..3;
S1RELADR = 0..1073741823; (*2**30 - 1*)
ESDINDEX = 1..MAXESDINDEX;
ESRINDEX = 1..MAXESRINDEX;
ZINDEX = 1..MAXZINDEX;
BANK = integer (*should be (RGS, MEM), but alignment*);
LINTVAL_OR_LCODEPTR = (LINTVAL,LCODEPTR);
XW_EV_OR_XW_C = (XW_EV,XW_C);
A_CODEREC = ↑CODEREC;
A_LBLHASHENT = ↑LBLHASHENT;
A_PROCENT = ↑PROCENT;
BITFIELD_LENGTH = 1..WORDBITS;
LBL_INDEX = 1..MAXLBL;
NUMBER_OF_PAREGS = 0..MAXPAREG;
RNG_0_LBLHTSIZEM1 = 0..LBLHTSIZEM1;
INDIRECTION = (IND0, IND1, IND2);
SFLDRNG = 0..SFLDMAX; (*VPA shift range*)
STKINX = MINSTKINX..MAXSTKINX;
OPNDTYPE_TO_BOOLEAN_ARRAY = array [OPNDTYPE] of boolean;
SETREP = set of 0..MAXSETEL;
CHAR2 = packed array [1..2] of char;
CHAR3 = packed array [1..3] of char;
CHAR4 = packed array [1..4] of char;
CHAR10 = packed array [1..10] of char;
CHAR12 = packed array [1..12] of char;
CHAR15 = packed array [1..15] of char;
CHAR17 = packed array [1..17] of char;
ALFALEN = 1..8;
ALFA = packed array [ALFALEN] of char;
NAMEREC = record NAM : ALFA; LEN : ALFALEN end;
NONNEGINT = 0..MAX_ON_COMP_MACH;
ZSYMBOL = packed array [1..8] of char; (*external symbol name*)
ZSEGTYPE = (ZIS,ZDS,ZCM);
ZESDTYPE = (ZST,ZIN,ZDN,ZAN);
ZESRTYPE = (ZIR,ZDR,ZAR,ZXR);
ZOPR = (ZPLUS,ZMINUS);
ZESDESRSEG = (ZESD,ZESR,ZSEG);
(*When *real* S1 words exist, this will just be an integer.*)
S1WORD =
record
LHALF, RHALF : integer
end (*S1WORD*);
CODEREC =
record
NEXTPTR : A_CODEREC;
case BIT of
0 : (CODEWORD : S1WORD);
1 : (CODEPTR : A_CODEREC)
end (*CODEREC*);
CODELIST = (*linked via NEXTPTR*)
record
NWORDS : 0..MAXCODEW;
FIRST, LAST : A_CODEREC;
end (*CODELIST*);
JUMPLIST = (*linked via CODEPTR*)
record
NWORDS : 0..MAXCODEW;
FIRST, LAST : A_CODEREC;
end (*JUMPLIST*);
LBLHASHENT =
record
LBLNUM : LBL_INDEX;
NEXTPTR : A_LBLHASHENT;
DEFINED : boolean;
case LINTVAL_OR_LCODEPTR of
LINTVAL : (INTVAL : integer; CLIST : CODELIST);
LCODEPTR : (CODEPTR : A_CODEREC; JLIST : JUMPLIST;
JUMPTABLELABEL : boolean)
end (*LBLHASHENT*);
PROCENT =
record
NAME : ALFA;
FIXLIST : CODELIST;
NEXTPTR : A_PROCENT
end (*PROCENT*);
NESTITEM =
record
PROCTYPE : OPNDTYPE;
PROCNAM : NAMEREC;
FIRSTPARMAREA,
SECONDPARMAREA,
VARAREA,
LCBEFPAR,
REGPARMAREA,
OFFSET_IN_VARS,
LOCALDATAOFFSET,
LOCALDATATRANSLATION :
integer
end (*NESTITEM*);
MSTENTRY =
record
DESTLEV : 1..MAXLVL; (*level of callee*)
LASTEXPR : STKINX; (*top index in virtual stack at MST*)
CURPARMREGS : NUMBER_OF_PAREGS;
(*number of parmregs used by caller*)
DESTFIRSTPARMAREA, DESTREGPARMAREA : integer;
(*sizes associated with callee*)
EVALSAVESTART : integer;
(*displacement into the evalsave of the
low end of the section used by this call*)
MSTCODESTART : A_CODEREC; (*Start of code from MST
(NEWINSTREC at entry to PMST)*)
end (*MSTENTRY*);
OPERANDXWORD =
record
case FMT : XW_EV_OR_XW_C of
XW_EV : (P, V, D, I : BIT;
S : 0..MAXINDEXSHIFT;
ADDR : S1ADDRESS;
REG : S1REGISTER;
DISP : S1DISP );
XW_C : (VAL : S1WORD)
end (*OPERANDXWORD*);
OPERAND =
record
X : BIT;
REG : S1REGISTER;
F : MINSHORTOFFSET..MAXSHORTOFFSET;
XW : OPERANDXWORD;
FIXUP : (NOFIX, STRINGFIX, SETFIX, REALFIX,
XTRNSYMFIX, BOUNDFIX);
FIXPTR : A_PROCENT; (*used only for XTRNSYMFIX*)
end (*OPERAND*);
LVLDSP =
record
DSPLMT : integer;
LVL : 0..MAXLVL
end (*LVLDSP*);
MEMOREG =
record
case WHICH : BANK of
RGS : (RGADR : S1REGISTER);
MEM : (MEMADR : LVLDSP)
end (*MEMOREG*);
VPAREC =
record
VSHIFT : SFLDRNG; (*amount to shift part after
evaluation and indirection.*)
VPAIND : IND1..IND2; (*indirection on this variable part.*)
VPA : MEMOREG; (*memory or register location.*)
end (*VPAREC*);
(*Type DATUM is the crux of this program. It represents a quantity on
the P-Machine stack during the process of executing the P-Code program
being translated. This quantity can be constant, in which case we have
its value in the datum; it may be a variable, in which case we have its
address in register or memory; or it may be a computed value, in which
case we may have the address of a temporary register containing the
quantity, or we may have several of any of the above along with other
information which all together tells what computation is needed beyond
the code which has already been emitted in order to calculate the
quantity.
The process of evaluating a datum can be described as follows. A
'MEMOREG' represents a register or memory address in the S1. Unless
indirected, the quantity represented is that address; thus the value of
a FPA with LVL=1 and DSPLMT=100 is the *address* of the 100th unit after
the unit addressed by the level 1 display register. We consider this a
constant even though it clearly depends on the run-time value of a
register.
If the MEMOREG is in a VPA, more may be done to it. A VPA has an
indirection associated with it of either 1 or 2. A VPA MEMOREG with
indirection 1 represents the quantity at the address described by the
MEMOREG. If the indirection is 2, the MEMOREG describes an address
where there is another address. The contents of the location at that
second address is the value of the quantity. After the appropriate
indirection is done, there may be a shift applied to the quantity (e.g.
if it is to be an index). Note that such a shift is applied after the
VPA indirection.
After the FPA and any active VPAs have been completely evaluated, we add
together their values and indirect the sum 0, 1, or 2 more times to get
the value of the datum itself. Thus for example if FINALIND is 0 the
datum value is the sum of the part values; if FINALIND is 1 the sum is
the *address* of the datum value. *)
DATUM =
record
CODESTART : A_CODEREC; (*pointer to first S1 instruction
in the evaluation of this datum*)
DTYPE : OPNDTYPE;
(*The following five fields only apply to booleans.*)
BREPRES : (BINTVAL, BJUMP);
(*tells whether boolean is represented
as a 0..1 value or as jump structure*)
BTRUELIST : JUMPLIST; (*list of jumps that are taken if the
datum is discovered to be true*)
BFALSELIST : JUMPLIST; (*list of jumps that are taken if the
datum is discovered to be false*)
BFALLTHRUSKIPLOC : A_CODEREC;
(*loc of last skip around jump in
code to evaluate boolean*)
BJUMPON : boolean; (*truth value for datum on which the
jump after the fallthruskip jumps*)
(*End of special boolean fields.*)
PCNST : SETREP; (*set value if set constant*)
RCNST : real; (*real value if real constant*)
FINALIND : IND0..IND2;
(*Final indirection depth of represented quantity.
IND0 : constant or constant wrt base.
IND1 : one indirection applied after evaluation.
IND2 : two indirections applied after evaluation.
FINALIND *must* be IND0 if there is no VPA
or if there is no FPA and only one VPA and that VPA
is at indirection IND1. That is, an indirection
applied to an FPA is recorded by making it a VPA,
and an indirection applied to a single VPA with
small internal indirection is recorded by increasing
that internal indirection.*)
FPA : MEMOREG; (*accumulated additive fixed part*)
NVPAS : 0..2; (*number of active VPAs. If only 1,
VPA1 is the active one.*)
VPA1 : VPAREC; (*variable parts : contents of the*)
VPA2 : VPAREC; (*described register or memory loc.*)
end (*DATUM*);
var
PRR : text; (*X10S1*)
OPC : P_OPCODE;
MNEM : CHAR3;
TYP : OPNDTYPE;
I1, I2, I3, I4, I5 : integer;
R1 : real;
P1 : SETREP;
NAM0, NAM1, NAM2 : NAMEREC;
SVAL : packed array [1..STRINGMAX] of char;
SLGTH : 0..STRINGMAX;
TR_PCODE, TR_S1CODE, TR_SIMP,
TR_STACK, TR_MST, TR_NEST : boolean;
OLDINSTREC : A_CODEREC;
OLDTOP : STKINX;
OLDMSTTOP : 0..MAXMST;
UNKNOWN_LOC : integer;
ASM : boolean;
DEBUG : boolean;
ASSERTCOUNT : integer;
CURPC : integer;
MAINCODE : CODELIST;
NEWINSTREC : A_CODEREC;
ERRINT1 : integer;
STRINGAREA : CODELIST;
NXTSTRDISP : integer;
STRINGAR_CPTR : A_CODEREC;
REALTBL, SETTBL, LOCTBL, BOUNDTBL : CODELIST;
STRINGFIXLIST, REALFIXLIST, SETFIXLIST, BOUNDFIXLIST : CODELIST;
NEG_SHIFT_FIXLIST : CODELIST;
(*Instructions on this list have OPND2s whose XW displacement
needs to be negated and shifted left at gen-segment time.*)
EVALSAVE :
record
SIZE : integer;
FIXLIST, NEGFIXLIST : CODELIST
end (*EVALSAVE*);
PROCTBL : record
NPROCS : integer;
FIRST : A_PROCENT
end (*PROCTBL*);
LBLHASHTAB : array [RNG_0_LBLHTSIZEM1] of A_LBLHASHENT;
CSPHASHTAB : array [0..CSPHTSIZEM1] of
record
CSPNAM : NAMEREC;
CSP : P_STANDARDPROC
end (*CSPHASHTAB*);
OPCHASHTAB : array [0..OPCHTSIZEM1] of
record
OPCNAM : CHAR3;
OPC : P_OPCODE
end (*OPCHASHTAB*);
FIRSTTYPE, LASTTYPE : OPNDTYPE;
FIRSTS1OP, LASTS1OP : S1OPCODE;
FIRSTSKIP, LASTSKIP : S1OPCODE;
ZERO_OP, EXTENDED_ZERO_OP : OPERAND; (*specify constant 0*)
EMPTY_OP : OPERAND; (*initted to valid but indeterminate value*)
UNUSED_OP : OPERAND; (*specify R0 for unused operands*)
ZEROS1WORD : S1WORD;
ZERODATUM : DATUM;
ZEROFPA : MEMOREG;
ZEROVPA : VPAREC;
EMPTYCODELIST : CODELIST;
EMPTYJUMPLIST : JUMPLIST;
OPNDRTB : OPERAND; (*specifies RTB*)
OPNDRSP : OPERAND; (*specifies the SP*)
SEG_EP_RELPC : integer; (*constant SEG_START_RELPC+SEG_EP_DISP*)
TWOEXP : array [0..MAX_EXP_ON_COMP_MACH] of integer;
CURPROC, MAXTMPPROC : ALFA;
CURPLOC, MAXTMPPLOC : integer;
CURLVL, MAXLVLUSED : 0..MAXLVL;
CURPROCXN : NAMEREC;
DISPLAY : S1REGISTER;
OLDNP : A_CODEREC; (*saves heap top pointer so space can be
reclaimed after generation of segment*)
HARDOPCODE : array [S1OPCODE] of HARDS1OPCODE;
SOFTOPCODE : array [HARDS1OPCODE] of S1OPCODE;
REVERSE_OP : array [S1OPCODE] of S1OPCODE;
OPFORMAT : array [S1OPCODE] of S1OPFORMAT;
S1MNEM : array [S1OPCODE] of CHAR15;
DEST_PRECISION : array [S1OPCODE] of S1PRECISION; (*PTZ*)
COLLAPSIBLE_OP : array [S1OPCODE] of boolean; (*PBK*)
(* indication of whether an XOP or TOP can be collapsed with a
following MOV*) (*PBK*)
INVERSE_SKIP : array [S1SKIPOPCODE] of S1SKIPOPCODE;
TYPECODE : array [OPNDTYPE] of char;
ALIGNBNDRY : array [OPNDTYPE] of ALIGNMENTBOUNDARY;
S1SIZE : array [OPNDTYPE] of S1Q..S1D;
FUNCUNITS : array [OPNDTYPE] of S1LENGTH;
IS_DOUBLE : OPNDTYPE_TO_BOOLEAN_ARRAY;
IS_SINGLE : OPNDTYPE_TO_BOOLEAN_ARRAY;
IS_INTEGER : OPNDTYPE_TO_BOOLEAN_ARRAY;
IS_REAL : OPNDTYPE_TO_BOOLEAN_ARRAY;
SKP_NON_X : array [OPNDTYPE] of S1OPCODE;
MOV_X_X : array [OPNDTYPE] of S1OPCODE;
ABS_X : array [OPNDTYPE] of S1OPCODE;
NEG_X : array [OPNDTYPE] of S1OPCODE;
MOVMQ_N : array [1..MAXMOVMQ] of S1OPCODE;
MOVMS_N : array [1..MAXMOVMS] of S1OPCODE; (*5DEC78 ALS*)
FLOAT_S_X : array [OPNDTYPE] of S1OPCODE;
FIX_DM_S_X : array [OPNDTYPE] of S1OPCODE;
SLR_N : array [S1REGISTER] of S1OPCODE;
SLRADR_N : array [S1REGISTER] of S1OPCODE;
BTRP_B_X : array [OPNDTYPE] of S1OPCODE;
BTRP_N_X : array [0..1, OPNDTYPE] of S1OPCODE;
MOV_X_Y : array [OPNDTYPE, OPNDTYPE] of S1OPCODE;
ARITH_RESULT_TYPE : array [OPNDTYPE, OPNDTYPE] of OPNDTYPE;
COMPARE_COERCE_TYPE : array [OPNDTYPE, OPNDTYPE] of OPNDTYPE;
REAL_ARITH_OP : array [S1S..S1D, PADR..PDVR] of S1OPCODE;
COMPARE_OP : array [S1Q..S1D, PEQU..PLES] of S1OPCODE;
BLKCMP_X_Q : array [PEQU..PLES] of S1OPCODE;
RISFREE : array [S1REGISTER] of boolean;
RPWORD : array [S1REGISTER] of (RSINGLE, R1STOFPAIR, R2NDOFPAIR); (*PBK*)
GISFREE : array [S1GBL] of boolean;
NXTRG : S1REGISTER;
MINTMPS1REG, MAXTMPS1REG, MINDSPS1REG : S1REGISTER;
RTBUSER : STKINX; (*stack index for datum using RTB*)
RTBDOUB : boolean; (*true iff RTBUSER is a doubleword quantity*)
LVL_TO_S1REG : array [1..MAXLVL] of S1REGISTER;
PRM_TO_S1REG : array [0..MAXPAREGM1] of S1REGISTER;
S1REG_TO_PRM : array [S1REGISTER] of integer;
ZSEGTYPE_TO_CHARS : array [ZSEGTYPE] of CHAR4;
ZESDTYPE_TO_CHARS : array [ZESDTYPE] of CHAR4;
ZESRTYPE_TO_CHARS : array [ZESRTYPE] of CHAR4;
ZIXFLAG_TO_CHAR : array [ZESDESRSEG] of char;
ZOPR_TO_CHARS : array [ZOPR] of CHAR2;
LOCALSIZELNUM : LBL_INDEX;
JUMPS_CONCRETIZED : boolean;
JUMPTABLE_IN_PROGRESS : boolean;
STK : array [STKINX] of DATUM;
TOP : STKINX;
MSTSTK : array [0..MAXMST] of MSTENTRY;
MSTTOP : 0..MAXMST;
NESTDISPLAY : array [0..MAXLVL] of NESTITEM;
TIMER : integer;
ERRORCNT : NONNEGINT;
S1OP_CNT : array [S1OPCODE] of integer; (*LCW*)
S1OP_TOT : integer; (*LCW*)
S1OP : S1OPCODE; (*LCW*)
WORD_CNT : integer; (*LCW*)
PEEP_PASSES_REQRD : integer; (*PTZ*)
GETFIELD_CNT : integer; (*PTZ*)
INSTR_WDS_REMOVED : integer; (*PTZ*)
J_TO_J_CNT : integer; (*PBK*)
JMPAS_REMOVED_FROM_SKIPS : integer; (*PTZ*)
MOVS_COLLAPSED : integer; (*PTZ*)
(** ERROR_CLASS: ERREXIT ASSERT ERROR **)
(**)
function FLDW(NUM : integer) : integer;
forward;
procedure ERREXIT (CODE : integer);
begin
WRITELN(OUTPUT,'**** ERREXIT called with code =',CODE);
(* EXIT(4097) *) (*X10S1*)
HALT (*X10S1*)
end;
procedure ASSERTFAIL(MSG : CHAR12);
(*ASSERTFAIL is used for internal consistency checking of the program.
The BOOLEAN that is a parameter in the ASSERT calls is here tested
before calling ASSERTFAIL, to avoid needless procedure calls.
The message in MSG is printed (to identify the particular
assertion) togather with an assertion count (now only a count of
the failed assertions) and execution is terminated. Note, that as it
is, only one failure will be reported. By not EXITTing one might get
more information from an attempted compilation.*)
begin
ASSERTCOUNT := ASSERTCOUNT + 1;
WRITELN(OUTPUT);
WRITELN(OUTPUT);
WRITELN(OUTPUT,'***** ERROR ***** Assertion #',ASSERTCOUNT:6,
' failed : ',MSG,' *****');
ASSERTCOUNT := ASSERTCOUNT div (ASSERTCOUNT-ASSERTCOUNT);
ERREXIT(9999)
end (*ASSERTFAIL*);
(* To be replaced by ASSERTFAIL above and all calls changed 11/29/78 ALS*)
procedure ASSERT(MSG : CHAR12; CONDITION : boolean);
(*ASSERT is used for internal consistency checking of the program.
It tests the condition (typically a boolean expression stating
something that should always be true at that point in the
program) for being *true*. If so, ASSERT returns quietly. If
not, the message in MSG is printed (to identify the particular
assertion) and execution is terminated.*)
begin
ASSERTCOUNT := ASSERTCOUNT + 1;
if CONDITION then (*normal case...just return*)
else
begin
WRITELN(OUTPUT);
WRITELN(OUTPUT);
WRITELN(OUTPUT,'***** ERROR ***** Assertion #',ASSERTCOUNT:6,
' failed : ',MSG,' *****');
ASSERTCOUNT := ASSERTCOUNT div (ASSERTCOUNT-ASSERTCOUNT);
ERREXIT(9999)
end
end (*ASSERT*);
(*Deletion to here ALS 11/29/78 *)
procedure ERROR(CODE : ERRORCODE);
(*This procedure is called whenever an error condition is detected
in the input P-Code. At the very least, it prints a message
describing the error. For the time being, it then gives up the
ghost and halts execution.*)
begin
ERRORCNT := ERRORCNT + 1;
WRITE(OUTPUT,' *ERROR* ');
case CODE of
WABR_OR_NGR_OF_NONREAL :
begin
WRITELN(OUTPUT,'ABR or NGR applied to non-real')
end;
WADDR_OUT_OF_RANGE :
begin
WRITELN(OUTPUT,
'Fixed-up address exceeds 30-bit S1 address space')
end;
WADDRESS_CHECK_ON_NONADDRESS :
begin
WRITELN(OUTPUT,'CHK type A applied to non-address')
end;
WALIGNMENT_ERROR :
begin
WRITELN(OUTPUT,'Alignment error')
end;
WANDOR_NEEDS_BOOLEAN :
begin
WRITELN(OUTPUT,'AND or IOR applied to non-boolean')
end;
WBINARY_OPND_TYPE_CONFLICT :
begin
WRITELN(OUTPUT,
'Invalid or conflicting operand types for binary operation')
end;
WCHECKED_CONSTANT_OUT_OF_RANGE :
begin
WRITELN(OUTPUT,
'CHK constant operand out of specified range')
end;
WCHECKING_INVALID_TYPE :
begin
WRITELN(OUTPUT,'CHK applied to invalid operand type')
end;
WCHR_NEEDS_INT :
begin
WRITELN(OUTPUT,'CHR applied to non-integer')
end;
WCOERCION_INVALID :
begin
WRITELN(OUTPUT,'Invalid type coercion')
end;
WCOMPARE_ILLEGAL :
begin
WRITELN(OUTPUT,
'Invalid or conflicting operand types for compare operation')
end;
WCOMPM_NEEDS_ADDR :
begin
WRITELN(OUTPUT,'Compare type M applied to non-address')
end;
WDISP_OUT_OF_RANGE :
begin
WRITELN(OUTPUT,
'Fixed-up displacement exceeds 25 bit S1 limit')
end;
WEXPR_TOO_COMPLEX :
begin
WRITELN(OUTPUT,
'Expression too complex (or total proc nesting too deep)')
end;
WFILE_ADDRESS_NEEDED :
begin
WRITELN(OUTPUT,'Stack top must be file address')
end;
WFJP_NEEDS_BOOLEAN :
begin
WRITELN(OUTPUT,'FJP with non-boolean stack top')
end;
WFJP_WITH_NONEMPTY_STACK :
begin
WRITELN(OUTPUT,'FJP with non-singleton expr stack')
end;
WFLOAT_OF_INVALID_TYPE :
begin
WRITELN(OUTPUT,
'FLO or FLT applied to invalid operand type')
end;
WFUNC_CALLS_NESTED_TOO_DEEPLY :
begin
WRITELN(OUTPUT,
'Function calls nested too deeply in expression')
end;
WINCOMPATIBLE_TYPES :
begin
WRITELN(OUTPUT,'Incompatible types for storing')
end;
WINDEX_WITHOUT_BASE :
begin
WRITELN(OUTPUT,'IND on (shifted) index without base')
end;
WINDEXING_IN_PARMS :
begin
WRITELN(OUTPUT,
'Indexing within fast (register) parameter area')
end;
WINN_REQUIRES_SET_ON_TOP_OF_STACK :
begin
WRITELN(OUTPUT,'INN on non-set second operand')
end;
WINSTR_TYPE_NOT_DATUM_TYPE :
begin
WRITELN(OUTPUT, 'Type in P-Code command different',
' from type of stack top.')
end;
WINSUFF_PARMS_SPECIFIED :
begin
WRITELN(OUTPUT,
'CUP with insufficient parameters on stack')
end;
WINTEGER_CONSTANT_DIV_MOD_BY_ZERO :
begin
WRITELN(OUTPUT,'DVI or mod by integer constant zero')
end;
WINVAL_CSP :
begin
WRITELN(OUTPUT, 'Invalid standard procedure name')
end;
WINVAL_OPC :
begin
WRITELN(OUTPUT, 'Invalid P-Code opcode')
end;
WINVAL_TRACE :
begin
WRITELN(OUTPUT, 'Invalid trace argument')
end;
WINVAL_TYP_ON_LDC :
begin
WRITELN(OUTPUT,'LDC type argument invalid')
end;
WINVALID_DISPLACEMENT :
begin
WRITELN(OUTPUT,
'Fixed-up displacement exceeds 25 bit S1 limit')
end;
WINVALID_IMPLICIT_TYPE_COERCION :
begin
WRITELN(OUTPUT,'Invalid implicit type coercion')
end;
WINVALID_LEVEL :
begin
WRITELN(OUTPUT, 'Invalid level in P-Code instruction')
end;
WINVALID_TYPE_CODE :
begin
WRITELN(OUTPUT, 'Invalid type on P-Code instruction')
end;
WIXA_NEEDS_ADDR :
begin
WRITELN(OUTPUT,'IXA on non-address first operand')
end;
WLAST_SST_PARM_TOO_BIG :
begin
WRITELN(OUTPUT, 'Last SST parameter bigger than MAXPAREG')
end;
WL_LPTR_LBLNUM_UNDEFINED :
begin
WRITELN(OUTPUT,
'Undefined label : L',ERRINT1:FLDW(ERRINT1))
end;
WLOADING_STRING :
begin
WRITELN(OUTPUT,
'IND loading string (indirect thru string constant illegal)')
end;
WMOV_NEEDS_ADDRS :
begin
WRITELN(OUTPUT,'MOV with non-address operand(s)')
end;
WMST_SPECIFIED_INSUFF_PARM_STORAGE :
begin
WRITELN(OUTPUT,
'MST specified insufficient parameter storage')
end;
WMST_WITHOUT_CUP_IN_LAST_SEGMENT :
begin
WRITELN(OUTPUT,
'MST without corresponding CUP in last segment')
end;
WMULT_DEFINED_LAB :
begin
WRITELN(OUTPUT,'Multiply defined label')
end;
WNESTING_TOO_DEEP_OR_EXPRESSION_TOO_COMPLEX :
begin
WRITELN(OUTPUT,
'Total proc nesting too deep (or some expr too complex)')
end;
WNEW_MUST_HAVE_ADDR_AND_INT :
begin
WRITELN(OUTPUT,
'NEW operands not (1) address and (2) integer')
end;
WNOT_AN_ADDR :
begin
WRITELN(OUTPUT,'IND applied to non-address type')
end;
WNOT_DISCRETE_TYPE :
begin
WRITELN(OUTPUT,
'INC, DEC, PRE, or SUC applied to non-discrete type')
end;
WNOT_NEEDS_BOOLEAN :
begin
WRITELN(OUTPUT,'not applied to non-boolean')
end;
WNULLREF :
begin
WRITELN(OUTPUT,'IND applied to nil')
end;
WODD_REQUIRES_AN_INTEGER :
begin
WRITELN(OUTPUT,'ODD applied to non-integer')
end;
WORD_NEEDS_INT_BOOLEAN_OR_CHAR :
begin
WRITELN(OUTPUT,
'ORD operand not integer, boolean, or char')
end;
WPOP_OF_EMPTY_STACK :
begin
WRITELN(OUTPUT,
'Pop of empty expr stack (stack underflow)')
end;
WREAL_CONSTANT_DIVISION_BY_ZERO :
begin
WRITELN(OUTPUT,'DVR by real constant zero')
end;
WREGPARMS_SPEC_TOO_LOW_IN_MST :
begin
WRITELN(OUTPUT,
'MST specified insufficient register parameter storage')
end;
WRST_NEEDS_ADDR :
begin
WRITELN(OUTPUT,'RST operand not address')
end;
WSAV_NEEDS_ADDR :
begin
WRITELN(OUTPUT,'SAV operand not address')
end;
WSET_OPERATION_ON_NONSET_TYPES :
begin
WRITELN(OUTPUT,'Set operation applied to non-set')
end;
WSGS_OR_INN_REQUIRES_INT_CHAR_OR_BOOLEAN :
begin
WRITELN(OUTPUT,
'SGS or INN (first) operand not integer, boolean, or char')
end;
WSIO_DIDNT_SEE_FILEADDR :
begin
WRITELN(OUTPUT,'SIO didnt see file addr')
end;
WSIO_WITH_NONADDRESS :
begin
WRITELN(OUTPUT,'SIO operand not address')
end;
WSQUARE_OF_INVALID_TYPE :
begin
WRITELN(OUTPUT,'SQI or SQR operand type invalid')
end;
WSST_AND_ENT_INCONSISTENT :
begin
WRITELN(OUTPUT,'SST and ENT inconsistent')
end;
WSST_AND_RET_INCONSISTENT :
begin
WRITELN(OUTPUT,'SST and RET inconsistent')
end;
WSTACK_LEFT_NONEMPTY_IN_LAST_SEGMENT :
begin
WRITELN(OUTPUT,'Expr stack left nonempty in last segment')
end;
WSTACK_NON_EMPTY :
begin
WRITELN(OUTPUT, 'Expression stack should have been ',
'empty after last instruction')
end;
WSTACK_NOT_SINGLE :
begin
WRITELN(OUTPUT, 'Expression stack should have ',
'contained exactly one element ',
'after last instruction')
end;
WTRUNCATE_OF_INVALID_TYPE :
begin
WRITELN(OUTPUT,'TRC operand type invalid')
end;
WUJP_WITH_NONEMPTY_STACK :
begin
WRITELN(OUTPUT,'UJP with nonempty expr stack')
end;
WWRONG_COMPARE :
begin
WRITELN(OUTPUT,
'Wrong compare operator for given operand types')
end;
WXJP_WITHOUT_SINGLETON_STACK :
begin
WRITELN(OUTPUT,'XJP with non-singleton expr stack')
end
end (*case*);
if not (FALSE) then
ASSERTFAIL('ERROR 999'); (*temporary to get traceback*)
ERREXIT(1000) (*Basic giving-up-the-ghost action.*)
end (*ERROR*);
(** DEBUGGING_CLASS: PRINTSET PRINTMEMOREG PRINTDATUM PRINT_NESTITEM PRINT_MSTENTRY PRINTNXTINST PRINTNAM PRINTTYP PRINTINT **)
(**)
function IS_CONSTANT (STE : STKINX) : boolean;
forward;
procedure DISASSEMBLE(var CURPC : integer; IPTR : A_CODEREC);
forward;
function GETS1OPCODE (INSTLOC : A_CODEREC) : S1OPCODE;
forward;
function JUMPSKIPDEST(INSTLOC : A_CODEREC) : A_CODEREC;
forward;
procedure PRINTSET (S : SETREP);
(*Print the set.*)
var I : 0..MAXSETEL;
COUNT : integer;
begin
WRITE (OUTPUT, ' [');
COUNT := 0;
for i := 0 to MAXSETEL do
if I in S then
begin
if COUNT > 20 then
begin
WRITELN(OUTPUT);
WRITE (OUTPUT, ' ');
COUNT := 0;
end;
WRITE (OUTPUT, I : 3);
COUNT := COUNT + 1;
end;
WRITELN (OUTPUT, '].');
end (*PRINTSET*);
procedure PRINTMEMOREG (var X : MEMOREG);
(*Print the memoreg without changing lines.*)
begin
if X.WHICH = RGS then
begin
if X.RGADR = S1RTA then
WRITE (OUTPUT, 'RTA')
else if X.RGADR = S1RTB then
WRITE (OUTPUT, 'RTB')
else
WRITE (OUTPUT, 'R', ord(X.RGADR) : FLDW(ord(X.RGADR)) )
end
else if X.MEMADR.LVL = 0 then
WRITE (OUTPUT, X.MEMADR.DSPLMT : FLDW(X.MEMADR.DSPLMT) )
else
WRITE (OUTPUT, '<L', X.MEMADR.LVL : FLDW(X.MEMADR.LVL),
',', X.MEMADR.DSPLMT : FLDW(X.MEMADR.DSPLMT), '>' );
end (*PRINTMEMOREG*);
procedure PRINTDATUM (STE : STKINX);
(*Print the datum for trace or debugging purposes.*)
var PTR : A_CODEREC;
I : integer;
UNKNOWN_LOC : integer;
begin
with STK[STE] do
begin
WRITELN (OUTPUT, ' STK[', STE : FLDW(STE), '] IS' );
WRITE (OUTPUT, ' TYP', TYPECODE[DTYPE], ' = ');
if (DTYPE = TYPR) and IS_CONSTANT(STE) then
WRITELN (OUTPUT, RCNST)
else if (DTYPE = TYPS) and IS_CONSTANT(STE) then
PRINTSET (PCNST)
else if (DTYPE = TYPB) and (BREPRES = BJUMP) then
begin
WRITELN (OUTPUT, 'BJUMP with', BTRUELIST.NWORDS : 3,
' true jumps and', BFALSELIST.NWORDS : 3,
' false jumps.' );
WRITE (OUTPUT, ' BJUMPON is ');
if BJUMPON then WRITE (OUTPUT, 'TRUE')
else WRITE (OUTPUT, 'FALSE');
WRITELN (OUTPUT, ' and fall thru skip is');
UNKNOWN_LOC := 0;
DISASSEMBLE (UNKNOWN_LOC, BFALLTHRUSKIPLOC);
PTR := BTRUELIST.FIRST;
for I := 1 to BTRUELIST.NWORDS do
begin
if not ( PTR <> nil) then ASSERTFAIL('PRINTDATU001');
PTR := JUMPSKIPDEST(PTR);
end;
PTR := BFALSELIST.FIRST;
for I := 1 to BFALSELIST.NWORDS do
begin
if not ( PTR <> nil) then ASSERTFAIL('PRINTDATU001');
PTR := JUMPSKIPDEST(PTR);
end;
end
else
begin
WRITE (OUTPUT, ord(FINALIND) : 1, ': (' );
PRINTMEMOREG (FPA);
if NVPAS > 0 then
begin
WRITE (OUTPUT, ', ', ord(VPA1.VPAIND) : 1, ': (' );
PRINTMEMOREG (VPA1.VPA);
WRITE (OUTPUT, ')*', TWOEXP[VPA1.VSHIFT] : 1 );
end;
if NVPAS = 2 then
begin
WRITE (OUTPUT, ', ', ord(VPA2.VPAIND) : 1, ': (' );
PRINTMEMOREG (VPA2.VPA);
WRITE (OUTPUT, ')*', TWOEXP[VPA2.VSHIFT] : 1 );
end;
WRITELN (OUTPUT, ').' );
end;
WRITE (OUTPUT,
' Code starts with the instruction ');
if CODESTART = NEWINSTREC then
WRITELN (OUTPUT, 'at NEWINSTREC.')
else
WRITELN (OUTPUT, S1MNEM[GETS1OPCODE(CODESTART)] );
end (*with*);
end (*PRINTDATUM*);
procedure PRINT_NESTITEM (INDEX : integer);
(*Print NESTDISPLAY[INDEX].*)
begin
with NESTDISPLAY[INDEX] do
begin
WRITELN (OUTPUT, ' NESTDISPLAY[',
INDEX : FLDW(INDEX), '] IS' );
WRITELN (OUTPUT, ' ', PROCNAM.NAM, ' TYP', TYPECODE[PROCTYPE],
' areas ', REGPARMAREA, FIRSTPARMAREA,
SECONDPARMAREA, VARAREA );
WRITELN (OUTPUT, ' displacements', LCBEFPAR,
OFFSET_IN_VARS, LOCALDATAOFFSET,
LOCALDATATRANSLATION );
end (*with*);
end (*PRINT_NESTITEM*);
procedure PRINT_MSTENTRY (INDEX : integer);
(*Print MSTSTK[INDEX].*)
begin
with MSTSTK[MSTTOP] do
begin
WRITELN (OUTPUT, ' MSTSTK[',
INDEX : FLDW(INDEX), '] is' );
WRITELN (OUTPUT, ' lev', DESTLEV : 2,
', expr', LASTEXPR : 3,
', pregs', CURPARMREGS : 3 );
WRITELN (OUTPUT,
' evalsave', EVALSAVESTART : FLDW(EVALSAVESTART),
', areas', DESTREGPARMAREA, DESTFIRSTPARMAREA );
end (*with*);
end (*PRINT_MSTENTRY*);
procedure PRINTNXTINST;
(*Print next P-Code instruction.*)
var I : 0..STRINGMAX;
procedure PRINTNAM (var NAM : NAMEREC);
(*Print two spaces and the name.*)
var I : 0..8;
begin
WRITE (OUTPUT, ' ');
for I := 1 to NAM.LEN do WRITE (OUTPUT, NAM.NAM[I]);
end (*PRINTNAM*);
procedure PRINTTYP (TYP : OPNDTYPE);
(*Print two blanks and the type code.*)
begin
WRITE (OUTPUT, ' ', TYPECODE[TYP]);
end (*PRINTTYP*);
procedure PRINTINT (I : integer);
(*Print two blanks and the integer.*)
begin
WRITE (OUTPUT, ' ', I : FLDW(I));
end (*PRINTINT*);
begin
if (OPC = PLAB) or (OPC = PDEF) or (OPC = PENT) then
PRINTNAM (NAM0)
else
WRITE (' ');
WRITE (OUTPUT, ' ', MNEM);
case OPC of
PSTP : (*null case*);
PENT : begin
PRINTTYP (TYP);
PRINTINT (I1);
PRINTNAM (NAM1);
PRINTNAM (NAM2);
PRINTINT (I2);
PRINTINT (I3);
PRINTINT (I4);
end;
PMST : begin
PRINTINT (I1);
PRINTINT (I2);
PRINTINT (I3);
end;
PLAB : (*null case*);
PDEF : PRINTINT (I1);
PSST : begin
PRINTTYP (TYP);
PRINTNAM (NAM1);
PRINTINT (I1);
PRINTINT (I2);
PRINTINT (I3);
PRINTINT (I4);
PRINTINT (I5);
end;
PTOF : PRINTNAM (NAM1);
PTON : begin
PRINTNAM (NAM1);
if NAM1.NAM <> 'PCODE ' then
begin
PRINTNAM (NAM2);
if (NAM2.NAM[1]='A') and (NAM1.NAM<>'S1CODE ') then
PRINTINT (I1)
end;
end;
(*opcode class 1*)
PABI, PABR, PADI, PADR, PAND, PCHR, PDIF, PDVI, PDVR,
PEOF, PFLO, PFLT, PINN, PINT, PIOR, PMOD, PMPI, PMPR,
PNGI, PNGR, PNOT, PODD, PORD, PPRE, PRST, PSAV, PSBI,
PSBR, PSGS, PSQI, PSQR, PSUC, PTRC, PUNI :
(*null case*);
(*opcode class 2*)
PBGN, PIXA, PLAO, PLOC, PMOV, PNEW :
PRINTINT (I1);
(*opcode class 3*)
PLDA:
begin
PRINTINT (I1); PRINTINT (I2);
end;
(*opcode class 4*)
PFJP, PUJP, PXJP :
PRINTNAM (NAM1);
(*opcode class 5*)
PEQU, PGEQ, PGRT, PLEQ, PLES, PNEQ :
begin
PRINTTYP (TYP);
if TYP = TYPM then PRINTINT (I1);
end;
(*opcode class 6*)
PRET, PSTO, PPAR :
PRINTTYP (TYP);
(*opcode class 7*)
PDEC, PINC, PIND, PLDO, PSRO :
begin
PRINTTYP (TYP);
PRINTINT (I1);
end;
(*opcode class 8*)
PCHK, PLOD, PSTR :
begin
PRINTTYP (TYP);
PRINTINT (I1); PRINTINT (I2);
end;
PCSP : PRINTNAM (NAM1);
PCUP : begin
PRINTTYP (TYP);
PRINTINT (I1);
PRINTNAM (NAM1);
end;
PLDC : begin
PRINTTYP (TYP);
case TYP of
TYPI : PRINTINT (I1);
TYPC : WRITE (OUTPUT, ' ''', chr(I1), '''');
TYPR : WRITE (OUTPUT, ' ', R1);
TYPN : (*null case*);
TYPB : PRINTINT (I1);
TYPS : PRINTSET (P1);
end (*case TYP of*);
end (*PLDC*);
PLCA : begin
WRITE (OUTPUT, ' ''');
for I := 1 to SLGTH do
WRITE (OUTPUT, SVAL[I]);
WRITE (OUTPUT, '''');
end (*PLCA*);
end (*case OPC of*);
WRITELN(OUTPUT);
end (*PRINTNXTINST*);
(** S1WORD_PROCESSOR_CLASS: NEWCODEREC GETFIELD GETSIGNEDFIELD PUTFIELD **)
(**)
procedure NEWCODEREC(var X : A_CODEREC);
(*Gets a fresh new CODEREC from the heap.*)
begin
new(X);
X↑.NEXTPTR := nil;
X↑.CODEWORD := ZEROS1WORD
end (*NEWCODEREC*);
function GETFIELD (var WORD : S1WORD; STARTBIT : S1BITNUM;
BITLEN : BITFIELD_LENGTH) : integer;
(*Returns in the low-order BITLEN bits of the result the unsigned
value of the field of WORD starting at bit number STARTBIT.
For the present, BITLEN must be <= BITS_ON_COMP_MACH - 1.
Bits are numbered from left to right starting at 0.
Note : this routine changes when S1WORDs really exist!*)
var W1, W2 : integer;
FIRSTAFTER : integer;
begin
GETFIELD_CNT := GETFIELD_CNT + 1; (*PTZ*)
W1 := WORD.LHALF;
W2 := WORD.RHALF;
FIRSTAFTER := STARTBIT + BITLEN;
if not ((BITLEN <= BITS_ON_COMP_MACH - 1) and
(0<=W1) and (W1<TWOEXP[18]) and
(0<=W2) and (W2<TWOEXP[18])) then ASSERTFAIL('GETFIELD 001');
if STARTBIT <= 17 then
if FIRSTAFTER > 18 then
(*crosses the 'halfword' boundary*)
GETFIELD:=
W1 mod TWOEXP[18-STARTBIT] * TWOEXP[FIRSTAFTER-18]
+ W2 div TWOEXP[36-FIRSTAFTER]
else
(*totally in left halfword*)
GETFIELD := (W1 mod TWOEXP[18-STARTBIT])
div TWOEXP[18-FIRSTAFTER]
else
(*totally in right halfword*)
GETFIELD := (W2 mod TWOEXP[36-STARTBIT])
div TWOEXP[36-FIRSTAFTER];
end (*GETFIELD*);
function GETSIGNEDFIELD (var WORD : S1WORD;
STARTBIT : S1BITNUM;
BITLEN : BITFIELD_LENGTH) : integer;
(*Do sign-extend on GETFIELD. BITLEN must be <= BITS_ON_COMP_MACH - 1.*)
var T : integer;
begin
if not ( BITLEN <= BITS_ON_COMP_MACH - 1) then ASSERTFAIL('GETSIGNED001');
T := GETFIELD (WORD, STARTBIT, BITLEN);
if (T>=TWOEXP[BITLEN-1]) and (BITLEN<WORDBITS) then
if BITLEN <= MAX_EXP_ON_COMP_MACH then
GETSIGNEDFIELD := T - TWOEXP[BITLEN]
else
begin
T := T - TWOEXP[MAX_EXP_ON_COMP_MACH];
GETSIGNEDFIELD := T - TWOEXP[MAX_EXP_ON_COMP_MACH];
end
else
GETSIGNEDFIELD := T;
end (*GETSIGNEDFIELD*);
procedure PUTFIELD (var WORD : S1WORD; STARTBIT : S1BITNUM;
BITLEN : BITFIELD_LENGTH; FIELDVAL : integer);
(*Copies the low order BITLEN bits from FIELDVAL into a field
in WORD starting at bit number STARTBIT. (Bits are numbered
from left to right starting at 0.) High-order bits in FIELDVAL
should be either all ones or all zeros. Note : this routine
changes when S1WORDs really exist! At present assumes that
BITLEN <= BITS_ON_COMP_MACH - 1.*)
var W1, W2 : integer;
P : integer;
FIRSTAFTER : integer;
begin
if not (BITLEN <= BITS_ON_COMP_MACH - 1) then ASSERTFAIL('PUTFIELD 001');
W1 := WORD.LHALF;
W2 := WORD.RHALF;
FIRSTAFTER := STARTBIT + BITLEN;
if not ((0<=W1) and (W1<TWOEXP[18]) and
(0<=W2) and (W2<TWOEXP[18])) then ASSERTFAIL('PUTFIELD 002');
(*Zero out sign-extend bits of FIELDVAL.*)
if FIELDVAL < 0 then
if BITLEN <= MAX_EXP_ON_COMP_MACH then
FIELDVAL := FIELDVAL + TWOEXP[BITLEN]
else
begin
FIELDVAL := FIELDVAL + TWOEXP[MAX_EXP_ON_COMP_MACH];
FIELDVAL := FIELDVAL + TWOEXP[MAX_EXP_ON_COMP_MACH];
end;
if not (0<=FIELDVAL) then ASSERTFAIL('PUTFIELD 003');
if BITLEN <= MAX_EXP_ON_COMP_MACH then
if not (FIELDVAL < TWOEXP[BITLEN]) then ASSERTFAIL('PUTFIELD 004');
if STARTBIT <= 17 then
if FIRSTAFTER > 18 then
begin (*crosses 'halfword' boundary*)
W1 := W1 - W1 mod TWOEXP[18-STARTBIT]
+ FIELDVAL div TWOEXP[FIRSTAFTER-18];
W2 := W2 mod TWOEXP[36-FIRSTAFTER]
+ FIELDVAL mod TWOEXP[FIRSTAFTER-18]
* TWOEXP[36-FIRSTAFTER];
end
else
(*entirely in left half*)
W1 := W1 - W1 mod TWOEXP[18-STARTBIT]
+ W1 mod TWOEXP[18-FIRSTAFTER]
+ FIELDVAL * TWOEXP[18-FIRSTAFTER]
else
(*entirely in right half*)
W2 := W2 - W2 mod TWOEXP[36-STARTBIT]
+ W2 mod TWOEXP[36-FIRSTAFTER]
+ FIELDVAL * TWOEXP[36-FIRSTAFTER];
WORD.LHALF := W1;
WORD.RHALF := W2;
end (*PUTFIELD*);
(** S1WORD_PROCESSOR_CLASS: REAL_TO_S1WORD ZSYMBOL_TO_S1WORDS INTEGER_TO_S1WORD SETREP_TO_S1WORDS **)
(**)
(* Comment out the 370 version...
Note that this procedure will not work until PASCAL supports
the type xreal.
procedure XREAL_TO_S1WORDS(var W1, W2 : S1WORD; XRVAL : xreal);
"*Translate an extended real value into a pair of S1 words.
WARNING: This routine is totally 370 PASCAL dependent;
It will be much simpler in its S-1 version.*"
type TRIT = 0..2;
var NEG : boolean;
EXP : integer;
TOP27, BOT29 : integer;
ICR : record
DUMMY : integer "*alignment*";
case TAG:TRIT of
0: (I: array [1..2] of integer);
1: (C: packed array [1..8] of char);
2: (R: real)
end;
begin
W1 := ZEROS1WORD; W2 := ZEROS1WORD;
ICR.R := XRVAL;
if ICR.R <> 0.0 then
begin
if ICR.R >= 0.0 then NEG := false else
begin ICR.R := -ICR.R; NEG := true end;
EXP := (ord(ICR.C[1]) - 64) * 4;
ICR.C[1] := chr(0);
TOP27 := ICR.I[1]*8 + ord(ICR.C[5]) div 32;
ICR.C[5] := chr(ord(ICR.C[5]) mod 32);
BOT29 := ICR.I[2];
while TOP27 < TWOEXP[26] do "*binary normalize*"
begin
EXP := EXP - 1;
BOT29 := BOT29 * 2;
TOP27 := TOP27 * 2;
if BOT29 >= TWOEXP[29] then
begin
BOT29 := BOT29 - TWOEXP[29];
TOP27 := TOP27 + 1
end
end;
EXP := EXP + 128; "*to excess 128*"
if NEG then "*want twos complement*"
begin
BOT29 := - BOT29;
if BOT29<>0 then TOP27 := TOP27 + 1;
TOP27 := - TOP27;
if (BOT29<>0) or (TOP27<>0) then EXP := EXP + 1;
EXP := - EXP
end;
PUTFIELD(W1,0,9,EXP);
PUTFIELD(W1,9,27,TOP27);
PUTFIELD(W2,0,29,BOT29)
end "*ICR <> 0.0*"
end "*XREAL_TO_S1WORDS*";
...*)
(* The following procedure will not work until PASCAL supports
the type xreal.
procedure XREAL_TO_S1WORDS(var W1, W2 : S1WORD; XRVAL : xreal);
"*Translate an extended real value into a pair of S1 words.
S-1 VERSION and PDP-10 VERSION (same procedure) *"
var RS10 : record "*for getting (only) word on PDP-10*"
case BIT of
0: (R: real; I: integer);
1: (S: set of 0..MAXSETEL)
end;
RSH : record "*for getting high order word on S-1*"
case BIT of
0: (I: integer; R: real);
1: (S: set of 0..MAXSETEL; J: integer);
end;
RSL : record "*for getting low order word on S-1*"
case BIT of
0: (R: real);
1: (S: set of 0..MAXSETEL);
end;
N : 0..MAXSETEL;
begin
RS10.R := 0.0;
RS10.I := -1;
if 36 in RS10.S then
begin "*PDP-10*"
RS10.R := XRVAL;
RS10.I := 0;
W1 := ZEROS1WORD;
for N := 0 to WORDBITS-1 do
if N in RS10.S then
PUTFIELD (W1, N, 1, 1);
W2 := ZEROS1WORD;
end "*PDP-10*"
else
begin "*S-1*"
RSH.I := 0;
RSH.R := XRVAL;
W1 := ZEROS1WORD;
for N := WORDBITS-1 downto 0 do
if N in RSH.S then
PUTFIELD (W1, WORDBITS-1-N, 1, 1);
RSL.R := XRVAL;
W2 := ZEROS1WORD;
for N := WORDBITS-1 downto 0 do
if N in RSL.S then
PUTFIELD (W2, WORDBITS-1-N, 1, 1);
end "*S-1*";
end "*XREAL_TO_S1WORDS*";
...*)
procedure REAL_TO_S1WORD(var W : S1WORD; RVAL : real); (*LCW*)
(*Translate a real value into one S1 word.
S-1 VERSION and PDP-10 VERSION (same procedure) *)
type TRIT = 0..2; (*EJG*)
var RS : record (*for getting word on PDP-10 or S-1*)
case TRIT of (*EJG*)
0: (R: real; I: integer);
1: (S: set of 0..MAXSETEL); (*EJG*)
2: (I2: integer; R2: real) (*EJG*)
end;
N : 0..MAXSETEL;
begin
RS.R := 0.0;
RS.I := -1;
if 36 in RS.S then
begin (*PDP-10*)
RS.R := RVAL;
RS.I := 0;
W := ZEROS1WORD;
for N := 0 to WORDBITS-1 do
if N in RS.S then
PUTFIELD (W, N, 1, 1);
end (*PDP-10*)
else
begin (*S-1*)
RS.I2 := 0;
RS.R2 := RVAL;
W := ZEROS1WORD;
for N := WORDBITS-1 downto 0 do
if N in RS.S then
PUTFIELD (W, WORDBITS-1-N, 1, 1);
end (*S-1*);
end (*REAL_TO_S1WORD*);
procedure ZSYMBOL_TO_S1WORDS(var W1, W2 : S1WORD; SNAM : ZSYMBOL);
(*Translate a symbol name into a pair of S1 words.*)
var I, STBIT : integer;
begin
W1 := ZEROS1WORD;
W2 := ZEROS1WORD;
STBIT := 0;
for I := 1 to WORDCHARS do
begin
PUTFIELD(W1,STBIT,CHARBITS,ord(SNAM[I])-CHARDIF); (*CHARDIF*)
STBIT := STBIT + CHARBITS
end;
STBIT := 0;
for I := 1 to WORDCHARS do
begin
PUTFIELD(W2,STBIT,CHARBITS,ord(SNAM[WORDCHARS+I])-CHARDIF); (*CHARDIF*)
STBIT := STBIT + CHARBITS
end
end (*ZSYMBOL_TO_S1WORDS*);
procedure INTEGER_TO_S1WORD (var W : S1WORD; I : integer);
(*Put the integer I into the S1WORD, sign-extended.*)
begin
W := ZEROS1WORD;
PUTFIELD (W, WORDBITS-(BITS_ON_COMP_MACH-1), BITS_ON_COMP_MACH-1, I);
if I < 0 then
PUTFIELD (W, 0, WORDBITS-(BITS_ON_COMP_MACH-1), -1);
end (*INTEGER_TO_S1WORD*);
procedure SETREP_TO_S1WORDS (var W1, W2 : S1WORD; SVAL : SETREP);
(*Translate a set value to a pair of S1WORDs.
When MAXSETEL increases this will still work, but it
would be faster to equivalence a set to two integers.*)
var N : 0..MAXSETEL;
begin
W1 := ZEROS1WORD;
W2 := ZEROS1WORD;
for N := MAXSETEL downto WORDBITS do
if N in SVAL then
PUTFIELD (W1, 2*WORDBITS-1-N, 1, 1);
for N := WORDBITS-1 downto 0 do
if N in SVAL then
PUTFIELD (W2, WORDBITS-1-N, 1, 1);
end (*SETREP_TO_S1WORDS*);
(** MISCELLANEOUS_CLASS: LABELHASH LABELNUMBER MIN MAX POWER2 FLDW CVOS_S1WORD_12 CVOS_12 CVOS_10 CSP_HASH OPC_HASH NAME_TO_CSP MNEM_TO_OPC **)
(**)
function LABELHASH (LNUM : LBL_INDEX) : RNG_0_LBLHTSIZEM1;
begin
LABELHASH := ABS(LNUM) mod LBLHTSIZE;
end (*LABELHASH*);
function LABELNUMBER (var NAME : NAMEREC) : LBL_INDEX;
(*Converts a label name into a label number.*)
var I : ALFALEN;
NUM : 0..MAXLBL;
begin
I := 2; (*Skip the initial 'L'.*)
NUM := 0;
while (I<8) and (NAME.NAM[I]<>' ') do
begin
NUM := NUM*10 + ord(NAME.NAM[I]) - ord('0');
I := I + 1;
end;
if NAME.NAM[I] = ' ' then LABELNUMBER := NUM
else LABELNUMBER := NUM*10 + ord(NAME.NAM[I]) - ord('0');
end (*LABELNUMBER*);
function MIN (X, Y : integer) : integer;
begin
if X < Y then MIN := X else MIN := Y;
end (*MIN*);
function MAX (X, Y : integer) : integer;
begin
if X > Y then MAX := X else MAX := Y;
end (*MAX*);
function POWER2 (X : integer) : integer;
(*Return the integer k such that 2**k = X if X is a power of 2.
Otherwise return some k < 0.*)
var COUNT : integer;
begin
if X <= 0 then POWER2 := -999
else if X = 1 then POWER2 := 0
else if ODD(X) then POWER2 := -999
else if X = 2 then POWER2 := 1
else if X = 4 then POWER2 := 2
else if X = 8 then POWER2 := 3
else if X = 16 then POWER2 := 4
else if X = 32 then POWER2 := 5
else
begin
COUNT := 0;
repeat
COUNT := COUNT + 1;
X := X div 2;
until ODD(X) or (X <= 32);
if X = 32 then POWER2 := COUNT + 5
else POWER2 := -999;
end;
end (*POWER2*);
function FLDW(*(NUM : integer) : integer*);
(*Returns the field width required to exactly contain (with no
spaces) the value NUM represented in decimal.*)
var FW : integer;
begin
FW := 0;
if NUM < 0 then
begin
FW := 1;
NUM := abs(NUM)
end;
repeat
NUM := NUM div 10;
FW := FW + 1
until NUM = 0;
FLDW := FW
end (*FLDW*);
procedure CVOS_S1WORD_12(var ANS : CHAR12; W : S1WORD);
(*Converts an S1WORD into an octal string of 12 characters.*)
var I : 1..12;
begin
for I := 1 to 12 do
ANS[I] := chr(ord('0') + GETFIELD(W,3*(I-1),3));
I := 1;
while (I < 12) and (ANS[I] = '0') do
begin
ANS[I] := ' ';
I := I + 1
end
end (*CVOS_S1WORD_12*);
procedure CVOS_12(var ANS : CHAR12; K : NONNEGINT);
(*Converts a non-negative integer into an octal string of 12 chars.*)
var I : 1..12;
begin
ANS := ' 0';
I := 12;
while K > 0 do
begin
ANS[I] := chr(ord('0') + (K mod 8));
K := K div 8;
I := I - 1
end
end (*CVOS_12*);
procedure CVOS_10(var ANS : CHAR10; K : NONNEGINT);
(*Converts a non-negative integer into an octal string of 10 chars.*)
var I : 1..10;
begin
ANS := ' 0';
I := 10;
while K > 0 do
begin
if not (I>0) then ASSERTFAIL('CVOS_10 001');
ANS[I] := chr(ord('0') + (K mod 8));
K := K div 8;
I := I - 1
end
end (*CVOS_10*);
function CSP_HASH (var NAM : ALFA) : integer;
begin
CSP_HASH := (ord(NAM[1])*676 + ord(NAM[2])*26 + ord(NAM[3]))
mod CSPHTSIZE;
end (*CSP_HASH*);
function OPC_HASH (var MNEM : CHAR3) : integer;
begin
OPC_HASH := (ord(MNEM[1])*676 + ord(MNEM[2])*26 + ord(MNEM[3]))
mod OPCHTSIZE;
end (*OPC_HASH*);
function NAME_TO_CSP (var NAME : NAMEREC) : P_STANDARDPROC;
(*Look up the name in a hash table.*)
var H : integer;
begin
H := CSP_HASH (NAME.NAM);
while (CSPHASHTAB[H].CSPNAM <> NAME) and
(CSPHASHTAB[H].CSPNAM.NAM <> ' ') do
H := (H + 1) mod CSPHTSIZE;
if CSPHASHTAB[H].CSPNAM = NAME then
NAME_TO_CSP := CSPHASHTAB[H].CSP
else ERROR (WINVAL_CSP);
end (*NAME_TO_CSP*);
function MNEM_TO_OPC (var MNEM : CHAR3) : P_OPCODE;
(*Look up the mnemonic in a hash table.*)
var H : integer;
begin
H := OPC_HASH (MNEM);
while (OPCHASHTAB[H].OPCNAM <> MNEM) and
(OPCHASHTAB[H].OPCNAM <> ' ') do
H := (H + 1) mod OPCHTSIZE;
if OPCHASHTAB[H].OPCNAM = MNEM then
MNEM_TO_OPC := OPCHASHTAB[H].OPC
else ERROR (WINVAL_OPC);
end (*MNEM_TO_OPC*);
(** INSTRUCTION_PROCESSOR_CLASS: PTR_OPNDXWD S1OPNDS_EQUAL S1OPND_TEMPLOC GETS1OPCODE AFTER_LAST_XWORD JUMPSKIPDEST NEXT_INSTRUCTION AFTER_FAKEOPS INVERT_SKIP **)
(**)
function PTR_OPNDXWD (INSTLOC : A_CODEREC;
SHORTSTARTBIT : S1BITNUM) : A_CODEREC; (*PTZ*)
(*Return a pointer to the CODEREC which contains the extended
word of this instruction corresponding to the OPND specified
by SHORTSTARTBIT, assuming that this is a real S1 instruction.
If no extended OPND, return nil.*)
var INSTOPF : S1OPFORMAT;
XPTR : A_CODEREC;
begin
INSTOPF := OPFORMAT[GETS1OPCODE(INSTLOC)];
if not (INSTOPF<>VFAKEOP) then ASSERTFAIL('PTR_OPNDX001');
if (SHORTSTARTBIT = OPND2_START) and JUMPS_CONCRETIZED
and (INSTOPF = VJOP) and (GETFIELD(INSTLOC↑.CODEWORD,PR_START,PR_LEN) = 1)
then (*Real PR type jump - no OPND2 field*) PTR_OPNDXWD := nil
else
begin
XPTR := INSTLOC;
if GETFIELD(INSTLOC↑.CODEWORD,OPND2X_START,OPND2X_LEN)=1 then
XPTR := XPTR↑.NEXTPTR;
if (SHORTSTARTBIT = OPND1_START)
and (GETFIELD(INSTLOC↑.CODEWORD,OPND1X_START,OPND1X_LEN)=1) then
XPTR := XPTR↑.NEXTPTR;
if XPTR = INSTLOC then
PTR_OPNDXWD := nil
else
PTR_OPNDXWD := XPTR
end
end (*PTR_OPNXWD*);
function S1OPNDS_EQUAL (INST1LOC : A_CODEREC; INST1OPNDSTBIT : S1BITNUM;(*PTZ*)
INST2LOC : A_CODEREC;
INST2OPNDSTBIT : S1BITNUM) : boolean;
(*Return true iff the 2 operands (including extended words) are equal,
assuming that the instructions are real S1 instructions, and also
that we're NOT comparing jump or skip destinations.
This routine does not consider different ways of referring to the same
location as being equal - operands must be IDENTICAL to match*)
var X1PTR, X2PTR : A_CODEREC;
begin
if not (not ((OPFORMAT[GETS1OPCODE(INST1LOC)] = VJOP)
and (INST1OPNDSTBIT = OPND2_START))
and not ((OPFORMAT[GETS1OPCODE(INST2LOC)] = VJOP)
and (INST2OPNDSTBIT = OPND2_START))) then
ASSERTFAIL('S1OPNDS_E001');
if GETFIELD(INST1LOC↑.CODEWORD,INST1OPNDSTBIT,OPND_LEN)
= GETFIELD(INST2LOC↑.CODEWORD,INST2OPNDSTBIT,OPND_LEN) then
begin
X1PTR := PTR_OPNDXWD(INST1LOC,INST1OPNDSTBIT);
X2PTR := PTR_OPNDXWD(INST2LOC,INST2OPNDSTBIT);
if (X1PTR = nil) or (X2PTR = nil) then
S1OPNDS_EQUAL := X1PTR = X2PTR
else
S1OPNDS_EQUAL := X1PTR↑.CODEWORD = X2PTR↑.CODEWORD
end
else
S1OPNDS_EQUAL := false
end (*S1OPNDS_EQUAL*);
function S1OPND_TEMPLOC (INSTLOC : A_CODEREC; (*PTZ*)
SHORTSTARTBIT : S1BITNUM) : integer;
(*Return value >= 0 iff the OPND starting at SHORTSTARTBIT
of the instruction at INSTLOC is a temporary location.
Currently checks only for temp register or
RTA, RTB & returns the register number if the OPND is a
temporary location. Should be changed when temporaries
are allowed to spill onto the stack or elsewhere*)
var OPNDF : MINSHORTOFFSET..MAXSHORTOFFSET;
begin
OPNDF := GETSIGNEDFIELD
(INSTLOC↑.CODEWORD,SHORTSTARTBIT+OPNDF_START,OPNDF_LEN);
if (GETFIELD(INSTLOC↑.CODEWORD,SHORTSTARTBIT+OPNDX_START,OPNDX_LEN) = 0)
and (GETFIELD
(INSTLOC↑.CODEWORD,SHORTSTARTBIT+OPNDREG_START,OPNDREG_LEN) = 0)
and (((S1RTA <= OPNDF) and (OPNDF <= succ(S1RTB)))
or ((MINTMPS1REG <= OPNDF) and (OPNDF <= MAXTMPS1REG))) then
S1OPND_TEMPLOC := OPNDF
else
S1OPND_TEMPLOC := -1
end (*S1OPND_TEMPLOC*);
function GETS1OPCODE (*(INSTLOC : A_CODEREC) : S1OPCODE*);
(*Return the S1OPCODE translation of the hard opcode
in the instruction at INSTLOC.*)
begin
GETS1OPCODE :=
SOFTOPCODE [
GETFIELD
(INSTLOC↑.CODEWORD, OPCODE_START, OPCODE_LEN) ] ;
end (*GETS1OPCODE*);
function AFTER_LAST_XWORD(INSTLOC : A_CODEREC) : A_CODEREC;
(*Return a pointer to the CODEREC which follows the last extended
word of this instruction, assuming that this is a real S1
instruction.*)
var TPTR : A_CODEREC;
begin
if not (OPFORMAT[GETS1OPCODE(INSTLOC)] <> VFAKEOP) then
ASSERTFAIL('AFTER_LAS001');
TPTR := INSTLOC↑.NEXTPTR;
if JUMPS_CONCRETIZED and (OPFORMAT[GETS1OPCODE(INSTLOC)] = VJOP)
and (GETFIELD(INSTLOC↑.CODEWORD,PR_START,PR_LEN) = 1) then
(*Real PR type jump - no OPND2 field*)
else
if GETFIELD(INSTLOC↑.CODEWORD,OPND2X_START,OPND2X_LEN) =1 then
TPTR := TPTR↑.NEXTPTR;
if GETFIELD(INSTLOC↑.CODEWORD,OPND1X_START,OPND1X_LEN) = 1 then
TPTR := TPTR↑.NEXTPTR;
AFTER_LAST_XWORD := TPTR
end (*AFTER_LAST_XWORD*);
function JUMPSKIPDEST(*(INSTLOC : A_CODEREC) : A_CODEREC*);
(*Return value of jump or skip destination pointer.*)
var TPTR : A_CODEREC;
begin
if not (OPFORMAT[GETS1OPCODE(INSTLOC)] in [VJOP,VSOP]) then
ASSERTFAIL('JUMPSKIPD001');
TPTR := AFTER_LAST_XWORD(INSTLOC);
JUMPSKIPDEST := TPTR↑.CODEPTR
end (*JUMPSKIPDEST*);
function NEXT_INSTRUCTION(INSTLOC : A_CODEREC) : A_CODEREC;
(*Return pointer to instruction after the one addressed
by INSTLOC, allowing for extra words to hold jump or
skip destination pointers.*)
var TPTR : A_CODEREC;
S1OPF : S1OPFORMAT;
begin
S1OPF := OPFORMAT[GETS1OPCODE(INSTLOC)];
if S1OPF = VFAKEOP then
NEXT_INSTRUCTION := INSTLOC↑.NEXTPTR
else
begin (*not VFAKEOP*)
TPTR := AFTER_LAST_XWORD(INSTLOC);
if S1OPF in [VSOP,VJOP] then
NEXT_INSTRUCTION := TPTR↑.NEXTPTR
else
NEXT_INSTRUCTION := TPTR
end (*not VFAKEOP*)
end (*NEXT_INSTRUCTION*);
function AFTER_FAKEOPS(INSTLOC : A_CODEREC) : A_CODEREC;
(*Return pointer to first non-FAKEOP instruction
starting at INSTLOC or beyond.*)
var LOOKING : boolean;
begin
LOOKING := true;
while LOOKING do
if INSTLOC = nil then LOOKING := false
else
if OPFORMAT[GETS1OPCODE(INSTLOC)] = VFAKEOP
then INSTLOC := INSTLOC↑.NEXTPTR
else LOOKING := false;
AFTER_FAKEOPS := INSTLOC
end (*AFTER_FAKEOPS*);
procedure INVERT_SKIP (SKIPLOC : A_CODEREC);
(*Change the skip opcode at SKIPLOC to skip on the
inverse condition.*)
var SKP : S1SKIPDISTANCE;
S1OPC : S1OPCODE;
begin
SKP := GETFIELD (SKIPLOC↑.CODEWORD, SKP_START, SKP_LEN);
S1OPC := INVERSE_SKIP [GETS1OPCODE(SKIPLOC)];
PUTFIELD (SKIPLOC↑.CODEWORD, OPCODE_START, OPCODE_LEN,
HARDOPCODE[S1OPC]);
PUTFIELD (SKIPLOC↑.CODEWORD, SKP_START, SKP_LEN, SKP);
end (*INVERT_SKIP*);
(** FIXUP_CLASS: FIXSOP FIXJOP FIXOPND2 **)
(**)
procedure FIXSOP(SKIPLOC, SKIPDEST : A_CODEREC);
(*Set the destination pointer following the skip instruction to
point where SKIPDEST points.*)
var TPTR : A_CODEREC;
begin
if not (OPFORMAT[GETS1OPCODE(SKIPLOC)] = VSOP) then
ASSERTFAIL('FIXSOP 001');
TPTR := AFTER_LAST_XWORD(SKIPLOC);
TPTR↑.CODEPTR := SKIPDEST
end (*FIXSOP*);
procedure FIXJOP(JUMPLOC, JUMPDEST : A_CODEREC);
(*Set the destination pointer following the jump instruction to
point where JUMPDEST points.*)
var TPTR : A_CODEREC;
begin
if not (OPFORMAT[GETS1OPCODE(JUMPLOC)] = VJOP) then
ASSERTFAIL('FIXJOP 001');
TPTR := AFTER_LAST_XWORD(JUMPLOC);
TPTR↑.CODEPTR := JUMPDEST
end (*FIXJOP*);
procedure FIXOPND2 (INSTLOC : A_CODEREC; FIXVAL : integer);
(*Fixes the extended OPND2 field of the instruction by adding
FIXVAL to the appropriate part of it.The operand may be an
extended constant, a fixed-base address, or a variable-base
address.*)
var W : S1WORD;
CARRY : BIT;
T : integer;
UNKNOWN_LOC : integer;
begin
if not (GETFIELD(INSTLOC↑.CODEWORD,OPND2X_START,OPND2X_LEN) = 1) then
ASSERTFAIL('FIXOPND2 001');
if (GETFIELD(INSTLOC↑.CODEWORD,
OPND2REG_START, OPND2REG_LEN) = 1) and
(GETFIELD(INSTLOC↑.CODEWORD,
OPND2F_START, OPND2F_LEN) > 0) then
begin (*extended constant*)
(*Note : this section will be easier with real S1WORDs.*)
INTEGER_TO_S1WORD (W, FIXVAL);
with INSTLOC↑.NEXTPTR↑ do
begin
CARRY := 0;
T := CODEWORD.RHALF + W.RHALF;
if T < TWOEXP[18] then CODEWORD.RHALF := T
else
begin CARRY := 1;
CODEWORD.RHALF := T - TWOEXP[18];
end;
T := CODEWORD.LHALF + W.LHALF + CARRY;
CODEWORD.LHALF := T mod TWOEXP[18];
end;
end (*extended constant*)
else
with INSTLOC↑.NEXTPTR↑ do
if GETFIELD(CODEWORD, XWV_START, XWV_LEN) = 0 then
begin (*fixed-base address*)
T := FIXVAL +
GETSIGNEDFIELD(CODEWORD, XWADDR_START, XWADDR_LEN);
if (T<MINSIGNEDS1ADDR) or (T>MAXSIGNEDS1ADDR) then
ERROR (WADDR_OUT_OF_RANGE);
PUTFIELD (CODEWORD, XWADDR_START, XWADDR_LEN, T);
end (*fixed-base address*)
else
begin (*variable-base address*)
T := FIXVAL +
GETSIGNEDFIELD(CODEWORD, XWDISP_START, XWDISP_LEN);
if (T<MINS1DISP) or (T>MAXS1DISP) then
ERROR (WDISP_OUT_OF_RANGE);
(*probable cause: data area too large*)
PUTFIELD (CODEWORD, XWDISP_START, XWDISP_LEN, T);
end (*variable-base address*);
if TR_S1CODE then
begin
WRITELN (OUTPUT,
' Fixup performed to produce the instruction:');
UNKNOWN_LOC := 0;
DISASSEMBLE (UNKNOWN_LOC, INSTLOC);
end;
end (*FIXOPND2*);
(** FIXUP_CLASS: ADD_CODEPTR_TO_CODELIST ADD_JUMPLIST_PLUS_ONE ADD_JUMP_TO_JUMPLIST JUMP_TO_TABLE_RECORD_OR_FIX JUMP_TO_LABEL_RECORD_OR_FIX OPND2_RECORD_OR_FIX **)
(**)
procedure UPD_LBLTBL (var LPTR : A_LBLHASHENT; LNUM : LBL_INDEX;
LCLASS : LINTVAL_OR_LCODEPTR);
forward;
procedure ADD_CODEPTR_TO_CODELIST(var CL : CODELIST;
XCODEPTR : A_CODEREC);
(*Appends a new CODEREC to the front of codelist CL, containing
pointer XCODEPTR. Obtains a new CODEREC, but does not use
NEWINSTREC.*)
var X : A_CODEREC;
begin
NEWCODEREC(X);
X↑.CODEPTR := XCODEPTR;
X↑.NEXTPTR := CL.FIRST;
if CL.FIRST = nil then CL.LAST := X;
CL.FIRST := X;
CL.NWORDS := 1 + CL.NWORDS
end (*ADD_CODEPTR_TO_CODELIST*);
procedure ADD_JUMPLIST_PLUS_ONE(var JL1, JL2 : JUMPLIST;
JUMPLOC : A_CODEREC);
(*Appends JL2 onto JL1, and also appends the single jump at JUMPLOC
in FRONT of JL1.*)
begin
FIXJOP(JUMPLOC,JL1.FIRST);
if JL1.FIRST = nil then JL1.LAST := JUMPLOC;
JL1.FIRST := JUMPLOC;
FIXJOP(JL1.LAST,JL2.FIRST);
if JL2.FIRST <> nil then JL1.LAST := JL2.LAST;
JL1.NWORDS := 1 + JL1.NWORDS + JL2.NWORDS
end (*ADD_JUMPLIST_PLUS_ONE*);
procedure ADD_JUMP_TO_JUMPLIST(var JL : JUMPLIST;
JUMPLOC : A_CODEREC);
(*Appends the single jump at JUMPLOC onto the front of JL.*)
begin
FIXJOP(JUMPLOC,JL.FIRST);
if JL.FIRST = nil then JL.LAST := JUMPLOC;
JL.FIRST := JUMPLOC;
JL.NWORDS := 1 + JL.NWORDS
end (*ADD_JUMP_TO_JUMPLIST*);
procedure JUMP_TO_TABLE_RECORD_OR_FIX(JUMPLOC : A_CODEREC;
LNUM : LBL_INDEX);
(*Records the jump in the fixup list for this label number or else
fixes it immediately. Also flags label table entry as a
jumptable label and flags the jumps in the table if the table
already exists.*)
var LPTR : A_LBLHASHENT; PTR : A_CODEREC;
begin
UPD_LBLTBL(LPTR,LNUM,LCODEPTR);
with LPTR↑ do
begin
if not DEFINED then
ADD_JUMP_TO_JUMPLIST(JLIST,JUMPLOC)
else
begin (*DEFINED*)
FIXJOP(JUMPLOC,CODEPTR);
if not JUMPTABLELABEL then
begin
PTR := CODEPTR;
while (GETS1OPCODE(PTR) = XJMPA) and
(GETFIELD(PTR↑.CODEWORD,OPND2X_START,OPND2X_LEN) = 0)
do
begin
PUTFIELD(PTR↑.CODEWORD,PR_START,PR_LEN,1);
PTR := NEXT_INSTRUCTION(PTR)
end
end (*not JUMPTABLELABEL*)
end (*DEFINED*);
JUMPTABLELABEL := true
end (*with LPTR↑ do*)
end (*JUMP_TO_TABLE_RECORD_OR_FIX*);
procedure JUMP_TO_LABEL_RECORD_OR_FIX(JUMPLOC : A_CODEREC;
LNUM : LBL_INDEX);
(*Records the jump in the fixup list or fixes it immediately.*)
var LPTR : A_LBLHASHENT;
begin
UPD_LBLTBL(LPTR,LNUM,LCODEPTR);
with LPTR↑ do
if DEFINED then
FIXJOP(JUMPLOC,CODEPTR)
else
ADD_JUMP_TO_JUMPLIST(JLIST,JUMPLOC)
end (*JUMP_TO_LABEL_RECORD_OR_FIX*);
procedure OPND2_RECORD_OR_FIX(INSTLOC : A_CODEREC;
LNUM : LBL_INDEX);
(*Records the instruction in the LINTVAL fixup list or fixes it
up immediately.*)
var LPTR : A_LBLHASHENT;
begin
UPD_LBLTBL(LPTR,LNUM,LINTVAL);
with LPTR↑ do
if DEFINED then
FIXOPND2(INSTLOC,INTVAL)
else
ADD_CODEPTR_TO_CODELIST(CLIST,INSTLOC)
end (*OPND2_RECORD_OR_FIX*);
(** OPERAND_PROCESSOR_CLASS: ISREG IS_T_REG IS_T_REG_NOT_RT ISSHORTCONST ISCONST EQUAL_OPERANDS REG_OPERAND IMM_OPERAND REAL_IMM_OPERAND IS_RT IS_RTA IS_RTB USES_RTA USES_RTB **)
(**)
function FITS_SHRT_OFFSET (DISP : S1DISP) : boolean;
forward;
function ISREG (var OPND : OPERAND) : boolean;
(*Return true iff OPND specifies a register operand.*)
(*Note - this procedure is never used.*)
begin
ISREG := (OPND.X=0) and (OPND.REG=0);
end (*ISREG*);
function IS_T_REG (var OPND : OPERAND) : boolean;
(*Return true iff OPND specifies a register operand
which is a temporary register (including RTA, RTB),
as opposed to a parm or display register.*)
begin
IS_T_REG := (OPND.X=0) and (OPND.REG=0)
and (((S1RTA<=OPND.F) and (OPND.F<=succ(S1RTB)))
or ((MINTMPS1REG<=OPND.F) and (OPND.F<=MAXTMPS1REG)));
end (*IS_T_REG*);
function IS_T_REG_NOT_RT (var OPND : OPERAND) : boolean;
(*Return true iff OPND specifies a register operand
which is a temporary register (excluding RTB and RTA),
as opposed to a parm or display register.*)
begin
IS_T_REG_NOT_RT := (OPND.X=0) and (OPND.REG=0)
and (MINTMPS1REG<=OPND.F) and (OPND.F<=MAXTMPS1REG);
end (*IS_T_REG_NOT_RT*);
function ISSHORTCONST (var OPND : OPERAND) : boolean;
(*Return true iff OPND specifies a short-constant operand.*)
begin
ISSHORTCONST := (OPND.X=0) and (OPND.REG=1);
end (*ISSHORTCONST*);
function ISCONST (var OPND : OPERAND) : boolean;
(*Return true iff OPND specifies a constant operand.*)
(*Note - this procedure is never used, but could be.*)
begin
ISCONST := ( (OPND.X=0) and (OPND.REG=1) )
or ( (OPND.X=1) and (OPND.REG=1) and (OPND.F<>0) );
end (*ISCONST*);
function EQUAL_OPERANDS (var X, Y : OPERAND) : boolean;
(*Return true iff two operands are equal in all fields.*)
var EQSOFAR : boolean;
begin
EQSOFAR :=
(X.X = Y.X)
and (X.REG = Y.REG)
and (X.F = Y.F)
and (X.FIXUP = Y.FIXUP)
and (X.FIXPTR = Y.FIXPTR)
and (X.XW.FMT = Y.XW.FMT);
if EQSOFAR then
case X.XW.FMT of
XW_EV :
EQSOFAR :=
(X.XW.P = Y.XW.P)
and (X.XW.V = Y.XW.V)
and (X.XW.D = Y.XW.D)
and (X.XW.I = Y.XW.I)
and (X.XW.S = Y.XW.S)
and (X.XW.ADDR = Y.XW.ADDR)
and (X.XW.REG = Y.XW.REG)
and (X.XW.DISP = Y.XW.DISP);
XW_C :
EQSOFAR :=
(X.XW.VAL = Y.XW.VAL)
end (*case*);
EQUAL_OPERANDS := EQSOFAR
end (*EQUAL_OPERANDS*);
procedure REG_OPERAND (var OPND : OPERAND; R : S1REGISTER);
(*Build an operand specifying register R.*)
begin
OPND := EMPTY_OP;
OPND.X := 0;
OPND.REG := 0;
OPND.F := ord(R);
end (*REG_OPERAND*);
procedure IMM_OPERAND (var OPND : OPERAND; VAL : integer);
(*Build an operand which specifies a constant integer value VAL.*)
begin
if (MINSHORTCONSTANT <= VAL) and (VAL <= MAXSHORTCONSTANT) then
begin
OPND := ZERO_OP;
if not (OPND.REG=1) then ASSERTFAIL('IMM_OPERA001');
OPND.F := VAL
end
else
begin
OPND := EXTENDED_ZERO_OP;
INTEGER_TO_S1WORD (OPND.XW.VAL, VAL);
end;
end (*IMM_OPERAND*);
procedure REAL_IMM_OPERAND (var OPND : OPERAND; RVAL : real); (*LCW*)
(*Build an operand which specifies a constant real value VAL.*)
begin
if RVAL = 0.0 then
OPND := ZERO_OP
else
begin
OPND := EXTENDED_ZERO_OP;
REAL_TO_S1WORD (OPND.XW.VAL, RVAL);
end;
end (*REAL_IMM_OPERAND*);
function IS_RT (var OPND : OPERAND) : boolean;
(*Return true iff OPND specifies RTA or RTB.*)
(*Note - this procedure is never used.*)
begin
IS_RT := (OPND.X=0) and (OPND.REG=0)
and ( (OPND.F=ord(S1RTA)) or (OPND.F=ord(S1RTB)) );
end (*IS_RT*);
function IS_RTA (var OPND : OPERAND) : boolean;
(*Return true iff OPND specifies RTA.*)
begin
IS_RTA := (OPND.X=0) and (OPND.REG=0)
and (OPND.F=ord(S1RTA));
end (*IS_RTA*);
function IS_RTB (var OPND : OPERAND) : boolean;
(*Return true iff OPND specifies RTB.*)
begin
IS_RTB := (OPND.X=0) and (OPND.REG=0)
and (OPND.F=ord(S1RTB));
end (*IS_RTB*);
function USES_RTA(var OPND : OPERAND) : boolean;
(*Return true iff the operand uses RTA.*)
begin
if (OPND.REG = S1RTA) or
(OPND.REG = 0) and (OPND.F = ord(S1RTA)) then
USES_RTA := true
else if (OPND.X <> 1) or
(OPND.REG = 1) and (OPND.F <> 0) then USES_RTA := false
else USES_RTA := (OPND.XW.V=1) and (OPND.XW.REG=S1RTA);
end (*USES_RTA*);
function USES_RTB(var OPND : OPERAND) : boolean;
(*Return true iff the operand uses RTB.*)
begin
if (OPND.REG = S1RTB) or
(OPND.REG = 0) and (OPND.F = ord(S1RTB)) then
USES_RTB := true
else if (OPND.X <> 1) or
(OPND.REG = 1) and (OPND.F <> 0) then USES_RTB := false
else USES_RTB := (OPND.XW.V=1) and (OPND.XW.REG=S1RTB);
end (*USES_RTB*);
(** OPERAND_PROCESSOR_CLASS: EXTENDED_IMM_OPERAND REGDISP_OPERAND EXTENDED_REGDISP_OPERAND EXT_REGADDR_OPERAND ADDR_OPERAND **)
(**)
procedure EXTENDED_IMM_OPERAND (var OPND : OPERAND; VAL : integer);
(*Build an extended operand which specifies
the integer constant VAL.*)
begin
OPND := EXTENDED_ZERO_OP;
INTEGER_TO_S1WORD (OPND.XW.VAL, VAL);
end (*EXTENDED_IMM_OPERAND*);
procedure REGDISP_OPERAND (var OPND : OPERAND;
REG : S1REGISTER; DISP : S1DISP);
(*Build an operand specifying the address DISP(%REG). *)
begin
if FITS_SHRT_OFFSET(DISP) then
begin
OPND := EMPTY_OP;
OPND.X := 0;
OPND.REG := ord(REG);
OPND.F := DISP div WORDUNITS;
end
else
begin
OPND := EMPTY_OP;
OPND.X := 1;
OPND.REG := 1;
OPND.F := 0; (*short zero*)
OPND.XW.FMT := XW_EV;
OPND.XW.P := 0;
OPND.XW.V := 1;
OPND.XW.D := 0;
OPND.XW.I := 0;
OPND.XW.S := 0;
OPND.XW.REG := ord(REG);
OPND.XW.DISP := DISP;
end;
end (*REGDISP_OPERAND*);
procedure EXTENDED_REGDISP_OPERAND
(var OPND : OPERAND; REG : S1REGISTER; DISP : S1DISP);
(*Build an extended operand specifying the address DISP(%REG). *)
begin
OPND := EMPTY_OP;
OPND.X := 1;
OPND.REG := 1;
OPND.F := 0; (*short zero*)
OPND.XW.FMT := XW_EV;
OPND.XW.P := 0;
OPND.XW.V := 1;
OPND.XW.D := 0;
OPND.XW.I := 0;
OPND.XW.S := 0;
OPND.XW.REG := ord(REG);
OPND.XW.DISP := DISP;
end (*EXTENDED_REGDISP_OPERAND*);
procedure EXT_REGADDR_OPERAND (*EJG*)
(var OPND : OPERAND; REG : S1REGISTER; ADDR : S1ADDRESS);
(*Build an extended operand specifying the address ADDR(%REG). *)
begin
OPND := EMPTY_OP;
OPND.X := 1;
OPND.REG := 0;
OPND.F := ord(REG);
OPND.XW.FMT := XW_EV;
OPND.XW.P := 0;
OPND.XW.V := 0;
OPND.XW.D := 0;
OPND.XW.I := 0;
OPND.XW.S := 0;
OPND.XW.ADDR := ADDR;
end (*EXT_REGADDR_OPERAND*);
procedure ADDR_OPERAND (var OPND : OPERAND; ADDR : S1ADDRESS);
(*Build an operand which specifies the absolute address ADDR.*)
begin
OPND := EMPTY_OP;
OPND.X := 1;
OPND.REG := 1;
OPND.F := 0; (*short zero*)
OPND.XW.FMT := XW_EV;
OPND.XW.P := 0;
OPND.XW.V := 0;
OPND.XW.D := 0;
OPND.XW.I := 0;
OPND.XW.S := 0;
OPND.XW.ADDR := ADDR;
end (*ADDR_OPERAND*);
(** REGISTER/GLOBAL_MANAGEMENT_CLASS: ALLOCGBL FREEGBL_S ALLOCRG ALLOCRP FREERG_S FINDRP FINDRG MOVE_AND_FREE_RTB CURRENT_PARMREG_COUNT IS_PARMREG CHECK_DSP_TMP_COLLISION RESERVE_PARMREGS **)
(**)
procedure EMITFAKEINST(FAKEOPC : S1OPCODE; FAKEOPND : integer); (*PBK*)
forward;
procedure EMITXOP (S1OPC : S1OPCODE; var OPND1, OPND2 : OPERAND);
forward;
procedure ALLOCGBL (G : S1GBL);
(*Allocates a global (ie. low-core memory word) G.*)
begin
if not (GISFREE[G]) then ASSERTFAIL('ALLOCGBL 001');
GISFREE[G] := false;
end (*ALLOCGBL*);
procedure FREEGBL_S (G : S1GBL);
(*Frees a global or global pair starting with word G.
The name FREEGBL_S is intended to suggest FREEGBL(S). *)
begin
if not ( not GISFREE[G]) then ASSERTFAIL('FREEGBL_S001');
GISFREE[G] := true;
end (*FREEGBL_S*);
procedure ALLOCRG (R : S1REGISTER);
begin
if not (RISFREE[R]) then ASSERTFAIL('ALLOCRG 001');
RISFREE[R] := false;
RPWORD[R] := RSINGLE; (*PBK*)
end (*ALLOCRG*);
procedure ALLOCRP (R : S1REGISTER);
begin
if not ( RISFREE[R] and RISFREE[succ(R)] ) then ASSERTFAIL('ALLOCRP 001');
RISFREE[R] := false;
RISFREE[succ(R)] := false;
RPWORD[R] := R1STOFPAIR; (*PBK*)
RPWORD[succ(R)] := R2NDOFPAIR; (*PBK*)
end (*ALLOCRP*);
procedure FREERG_S(R : S1REGISTER);
(*Frees a register or register pair starting with R.
The name FREERG_S is intended to suggest FREERG(S). *)
begin
if not (not RISFREE[R] and (RPWORD[R]<>R2NDOFPAIR)) then
ASSERTFAIL('FREERG_S 001'); (*PBK*)
RISFREE[R] := true;
EMITFAKEINST(XFREEREG,R); (*PBK*)
if RPWORD[R] = R1STOFPAIR then (*PBK*)
begin
RISFREE[R+1] := true;
EMITFAKEINST(XFREEREG,R+1) (*PBK*)
end (* if RPWORD[R] = R1STOFPAIR then *); (*PBK*)
end (*FREERG_S*);
procedure FINDRP;
(*Find and allocate a pair of temporary registers (Not RTA or RTB).
Return the smaller reg number in global variable NXTRG.*)
begin
NXTRG := MINTMPS1REG;
while (NXTRG < MINDSPS1REG-2)
and not (RISFREE[NXTRG] and RISFREE[NXTRG+1]) do
NXTRG := NXTRG + 1;
if RISFREE[NXTRG] and RISFREE[NXTRG+1] then
begin
RISFREE[NXTRG] := false;
RISFREE[NXTRG+1] := false;
RPWORD[NXTRG] := R1STOFPAIR; (*PBK*)
RPWORD[NXTRG+1] := R2NDOFPAIR; (*PBK*)
if NXTRG+1 > MAXTMPS1REG then
begin
MAXTMPS1REG := NXTRG+1;
MAXTMPPROC := CURPROC;
MAXTMPPLOC := CURPLOC
end
end
else ERROR(WEXPR_TOO_COMPLEX)
end (*FINDRP*);
procedure FINDRG;
(*Find and allocate one of the temporary registers (Not RTA or
RTB), trying not to split potential pairs. Return reg number in
global variable NXTRG.*)
var I, ISAVE : S1REGISTER;
begin
NXTRG := MINTMPS1REG;
while (NXTRG < MINDSPS1REG-1) and not RISFREE[NXTRG] do
NXTRG := NXTRG + 1;
if not RISFREE[NXTRG] then
ERROR(WEXPR_TOO_COMPLEX)
else (*Found a free one (NXTRG). Can we improve on it?*)
begin
I := NXTRG;
while I <= MAXTMPS1REG do
begin
ISAVE := I;
repeat I := I + 1 until (I>MAXTMPS1REG) or not RISFREE[I];
if I-ISAVE = 1 then (*I-ISAVE = num of adjacent free regs*)
begin (*found an isolated free reg: use it*)
NXTRG := ISAVE;
I := MAXTMPS1REG + 1
end
else (*skip over next group of adjacent nonfree regs*)
while (I<=MAXTMPS1REG) and not RISFREE[I] do I := I + 1
end (*while I<=MAXTMPS1REG do*);
RISFREE[NXTRG] := false;
RPWORD[NXTRG] := RSINGLE; (*PBK*)
if NXTRG > MAXTMPS1REG then
begin
MAXTMPS1REG := NXTRG;
MAXTMPPROC := CURPROC;
MAXTMPPLOC := CURPLOC
end
end (*Found a free one*)
end (*FINDRG*);
procedure MOVE_AND_FREE_RTB;
(*We free RTB to use it to return function values or to
pass parameters to standard procs.
WARNING!!! This should not be called if an operand has
been built since it could invalidate the operand.*)
var MOVEOP : S1OPCODE;
OPNDR : OPERAND;
begin
if not (not RISFREE[S1RTB]) then ASSERTFAIL('MOVE_AND_001');
if RTBDOUB then
begin FINDRP; MOVEOP := XMOV_D_D end
else
begin FINDRG; MOVEOP := XMOV_S_S end;
REG_OPERAND(OPNDR,NXTRG);
EMITXOP(MOVEOP,OPNDR,OPNDRTB);
if not (RTBUSER <= TOP) then ASSERTFAIL('MOVE_AND_002');
with STK[RTBUSER] do
begin (*Update RTB datum to point to new reg*)
if FPA.WHICH = RGS then if FPA.RGADR = S1RTB then
FPA.RGADR := NXTRG;
if VPA1.VPA.WHICH = RGS then if VPA1.VPA.RGADR = S1RTB then
VPA1.VPA.RGADR := NXTRG;
if VPA2.VPA.WHICH = RGS then if VPA2.VPA.RGADR = S1RTB then
VPA2.VPA.RGADR := NXTRG
end;
FREERG_S(S1RTB)
end (*MOVE_AND_FREE_RTB*);
function CURRENT_PARMREG_COUNT : NUMBER_OF_PAREGS;
(*Returns the current number of parameter registers.*)
begin
CURRENT_PARMREG_COUNT := MINTMPS1REG - MINPARS1REG
end (*CURRENT_PARMREG_COUNT*);
function IS_PARMREG (R : S1REGISTER) : boolean;
(*Returns true iff R is a parameter register.*)
begin
IS_PARMREG := (MINPARS1REG<=R) and (R<MINTMPS1REG);
end (*IS_PARMREG*);
procedure CHECK_DSP_TMP_COLLISION;
(*Checks to see if there is a collision between the display
registers and the temporary registers. If so, an error message
is given; this is a non-recoverable situation requiring the user
to either simplify expressions or un-nest procedures.*)
begin
if MINDSPS1REG <= MAXTMPS1REG then
ERROR(WNESTING_TOO_DEEP_OR_EXPRESSION_TOO_COMPLEX)
end (*CHECK_DSP_TMP_COLLISION*);
procedure RESERVE_PARMREGS(COUNT : NUMBER_OF_PAREGS);
(*Changes the reservation to a given number of the parameter
registers, after asserting that any newly reserved ones are
available.*)
var I : S1REGISTER;
begin
for I := MINTMPS1REG to MINPARS1REG+COUNT-1 do
if not (RISFREE[I]) then ASSERTFAIL('RESERVE_P001');
MINTMPS1REG := MINPARS1REG + COUNT;
MAXTMPS1REG := MAX(MAXTMPS1REG,MINTMPS1REG-1);
CHECK_DSP_TMP_COLLISION
end (*RESERVE_PARMREGS*);
(** REGISTER/GLOBAL_MANAGEMENT_CLASS: FREEDATUMREGS FREEREGSBUTONE FREERGSBUTSOME FREEVPAREG FREEVPARGUNLESS FREE_TEMP_REGS **)
(**)
procedure FREEDATUMREGS (STE : STKINX);
(*Free all the temp expr regs (not display or parm regs)
used in the datum. Does *not* change the datum.*)
begin
if (STK[STE].FPA.WHICH=RGS) then
if (MINTMPS1REG<=STK[STE].FPA.RGADR) and
(STK[STE].FPA.RGADR<=MAXTMPS1REG) or
(STK[STE].FPA.RGADR in [S1RTA, S1RTB]) then
FREERG_S (STK[STE].FPA.RGADR);
if STK[STE].NVPAS >= 1 then
if (STK[STE].VPA1.VPA.WHICH=RGS) then
if (MINTMPS1REG<=STK[STE].VPA1.VPA.RGADR) and
(STK[STE].VPA1.VPA.RGADR<=MAXTMPS1REG) or
(STK[STE].VPA1.VPA.RGADR in [S1RTA, S1RTB]) then
FREERG_S(STK[STE].VPA1.VPA.RGADR);
if STK[STE].NVPAS = 2 then
if (STK[STE].VPA2.VPA.WHICH=RGS) then
if (MINTMPS1REG<=STK[STE].VPA2.VPA.RGADR) and
(STK[STE].VPA2.VPA.RGADR<=MAXTMPS1REG) or
(STK[STE].VPA2.VPA.RGADR in [S1RTA, S1RTB]) then
FREERG_S (STK[STE].VPA2.VPA.RGADR);
end (*FREEDATUMREGS*);
procedure FREEREGSBUTONE (STE : STKINX; R : S1REGISTER);
(*Free all the temp expr regs used in the datum,
*except* do not free register R if it is used.*)
begin
if (STK[STE].FPA.WHICH=RGS) then
if STK[STE].FPA.RGADR <> R then
if (MINTMPS1REG<=STK[STE].FPA.RGADR) and
(STK[STE].FPA.RGADR<=MAXTMPS1REG) or
(STK[STE].FPA.RGADR in [S1RTA, S1RTB]) then
FREERG_S (STK[STE].FPA.RGADR);
if STK[STE].NVPAS >= 1 then
if (STK[STE].VPA1.VPA.WHICH=RGS) then
if STK[STE].VPA1.VPA.RGADR <> R then
if (MINTMPS1REG<=STK[STE].VPA1.VPA.RGADR) and
(STK[STE].VPA1.VPA.RGADR<=MAXTMPS1REG) or
(STK[STE].VPA1.VPA.RGADR in [S1RTA, S1RTB]) then
FREERG_S(STK[STE].VPA1.VPA.RGADR);
if STK[STE].NVPAS = 2 then
if (STK[STE].VPA2.VPA.WHICH=RGS) then
if STK[STE].VPA2.VPA.RGADR <> R then
if (MINTMPS1REG<=STK[STE].VPA2.VPA.RGADR) and
(STK[STE].VPA2.VPA.RGADR<=MAXTMPS1REG) or
(STK[STE].VPA2.VPA.RGADR in [S1RTA, S1RTB]) then
FREERG_S (STK[STE].VPA2.VPA.RGADR);
end (*FREEREGSBUTONE*);
procedure FREERGSBUTSOME (STE, STE2 : STKINX);
(*Free all temp expr regs used in STK[STE], *except*
do not free any used in STK[STE2]. *)
(*NOTE - This procedure is never used.*)
var DONTFREE : set of S1REGISTER;
begin
DONTFREE := [ ];
if STK[STE].FPA.WHICH=MEM then
DONTFREE := DONTFREE + [STK[STE].FPA.RGADR];
if STK[STE].VPA1.VPA.WHICH=MEM then
DONTFREE := DONTFREE + [STK[STE].VPA1.VPA.RGADR];
if STK[STE].VPA2.VPA.WHICH=MEM then
DONTFREE := DONTFREE + [STK[STE].VPA2.VPA.RGADR];
if (STK[STE].FPA.WHICH=RGS) then
if not (STK[STE].FPA.RGADR in DONTFREE) then
if (MINTMPS1REG<=STK[STE].FPA.RGADR) and
(STK[STE].FPA.RGADR<=MAXTMPS1REG) or
(STK[STE].FPA.RGADR in [S1RTA, S1RTB]) then
FREERG_S (STK[STE].FPA.RGADR);
if STK[STE].NVPAS >= 1 then
if (STK[STE].VPA1.VPA.WHICH=RGS) then
if not (STK[STE].VPA1.VPA.RGADR in DONTFREE) then
if (MINTMPS1REG<=STK[STE].VPA1.VPA.RGADR) and
(STK[STE].VPA1.VPA.RGADR<=MAXTMPS1REG) or
(STK[STE].VPA1.VPA.RGADR in [S1RTA, S1RTB]) then
FREERG_S(STK[STE].VPA1.VPA.RGADR);
if STK[STE].NVPAS = 2 then
if (STK[STE].VPA2.VPA.WHICH=RGS) then
if not (STK[STE].VPA2.VPA.RGADR in DONTFREE) then
if (MINTMPS1REG<=STK[STE].VPA2.VPA.RGADR) and
(STK[STE].VPA2.VPA.RGADR<=MAXTMPS1REG) or
(STK[STE].VPA2.VPA.RGADR in [S1RTA, S1RTB]) then
FREERG_S (STK[STE].VPA2.VPA.RGADR);
end (*FREERGSBUTSOME*);
procedure FREEVPAREG (var V : VPAREC);
(*Free the temp expr reg used in V, if any. Does not change V.*)
begin
if V.VPA.WHICH = RGS then
if (MINTMPS1REG <= V.VPA.RGADR) and
(V.VPA.RGADR <= MAXTMPS1REG) or
(V.VPA.RGADR in [S1RTA, S1RTB]) then
FREERG_S (V.VPA.RGADR);
end (*FREEVPAREG*);
procedure FREEVPARGUNLESS (var V : VPAREC; R : S1REGISTER);
(*Free the temp expr reg used in V, if any, *EXCEPT* does
not free R if used. Does not change V.*)
begin
if V.VPA.WHICH = RGS then
if V.VPA.RGADR <> R then
if (MINTMPS1REG <= V.VPA.RGADR) and
(V.VPA.RGADR <= MAXTMPS1REG) or
(V.VPA.RGADR in [S1RTA, S1RTB]) then
FREERG_S (V.VPA.RGADR);
end (*FREEVPARGUNLESS*);
procedure FREE_TEMP_REGS;
(*Release all the temp expr regs, including RTA and RTB.*)
var R : S1REGISTER;
begin
if not RISFREE[S1RTA] then FREERG_S (S1RTA);
if not RISFREE[S1RTB] then FREERG_S (S1RTB);
for R := MINTMPS1REG to MAXTMPS1REG do
if not RISFREE[R] then FREERG_S (R);
end (*FREETEMPREGS*);
(** CODE_EMITTER_CLASS: BUILD_CW_OPERAND EMIT_INSTR_OPNDS INSERT_INSTR_OPNDS **)
(**)
procedure BUILD_CW_OPERAND(var SHORTWORD : S1WORD;
XWORDPTR : A_CODEREC;
var OPND : OPERAND;
SHORTSTARTBIT : S1BITNUM);
(*Build an S1 operand from OPND in SHORTWORD and XWORDPTR↑.
Position the first bit of the short part at bit SHORTSTARTBIT in
SHORTWORD; leave other 24 bits alone. Add the extended word to a
fixup list if necessary.*)
begin
PUTFIELD(SHORTWORD,SHORTSTARTBIT+OPNDX_START,OPNDX_LEN,OPND.X);
PUTFIELD(SHORTWORD,
SHORTSTARTBIT+OPNDREG_START,OPNDREG_LEN,OPND.REG);
PUTFIELD(SHORTWORD,SHORTSTARTBIT+OPNDF_START,OPNDF_LEN,OPND.F);
if OPND.FIXUP <> NOFIX then
begin
if not (OPND.X = 1) then ASSERTFAIL('BUILD_CW_001');
case OPND.FIXUP of
STRINGFIX: ADD_CODEPTR_TO_CODELIST(STRINGFIXLIST,XWORDPTR);
SETFIX: ADD_CODEPTR_TO_CODELIST(SETFIXLIST,XWORDPTR);
REALFIX: ADD_CODEPTR_TO_CODELIST(REALFIXLIST,XWORDPTR);
BOUNDFIX: ADD_CODEPTR_TO_CODELIST(BOUNDFIXLIST,XWORDPTR);
XTRNSYMFIX: ADD_CODEPTR_TO_CODELIST(OPND.FIXPTR↑.FIXLIST,
XWORDPTR)
end (*case*)
end (*if OPND.FIXUP <> NOFIX*);
if OPND.X = 1 then
begin (*extended word*)
if OPND.XW.FMT = XW_C then
begin
if not ((OPND.F > 0) and (OPND.REG = 1)) then
ASSERTFAIL('BUILD_CW_002');
XWORDPTR↑.CODEWORD := OPND.XW.VAL
end
else (*extended address*)
begin
if not (not ((OPND.F > 0) and (OPND.REG = 1))) then
ASSERTFAIL('BUILD_CW_003');
PUTFIELD(XWORDPTR↑.CODEWORD,XWP_START,XWP_LEN,OPND.XW.P);
PUTFIELD(XWORDPTR↑.CODEWORD,XWV_START,XWV_LEN,OPND.XW.V);
PUTFIELD(XWORDPTR↑.CODEWORD,XWD_START,XWD_LEN,OPND.XW.D);
PUTFIELD(XWORDPTR↑.CODEWORD,XWI_START,XWI_LEN,OPND.XW.I);
PUTFIELD(XWORDPTR↑.CODEWORD,XWS_START,XWS_LEN,OPND.XW.S);
if OPND.XW.V = 0 then
PUTFIELD(XWORDPTR↑.CODEWORD,
XWADDR_START,XWADDR_LEN,OPND.XW.ADDR)
else
begin
PUTFIELD(XWORDPTR↑.CODEWORD,
XWREG_START,XWREG_LEN,OPND.XW.REG);
PUTFIELD(XWORDPTR↑.CODEWORD,
XWDISP_START,XWDISP_LEN,OPND.XW.DISP)
end
end (*extended address*)
end (*extended word*)
end (*BUILD_CW_OPERAND*);
procedure EMIT_INSTR_OPNDS(var OPND1, OPND2 : OPERAND);
(*Common to EMIT routines. Fill in the short operand fields (at
NEWINSTREC), emit the instr. record, and allocate and emit
extended words if needed. Update MAINCODE to reflect
insertions.*)
var TPTR : A_CODEREC;
begin
if MAINCODE.FIRST = nil then MAINCODE.FIRST := NEWINSTREC
else MAINCODE.LAST↑.NEXTPTR := NEWINSTREC;
MAINCODE.LAST := NEWINSTREC;
NEWINSTREC↑.NEXTPTR := nil;
MAINCODE.NWORDS := MAINCODE.NWORDS + 1;
NEWCODEREC(TPTR);
BUILD_CW_OPERAND(NEWINSTREC↑.CODEWORD,TPTR,OPND2,OPND2_START);
if OPND2.X = 1 then
begin (*extended OPND2*)
MAINCODE.LAST↑.NEXTPTR := TPTR;
MAINCODE.LAST := TPTR;
TPTR↑.NEXTPTR := nil;
MAINCODE.NWORDS := MAINCODE.NWORDS + 1;
NEWCODEREC(TPTR)
end;
BUILD_CW_OPERAND(NEWINSTREC↑.CODEWORD,TPTR,OPND1,OPND1_START);
if OPND1.X = 1 then
begin (*extended OPND1*)
MAINCODE.LAST↑.NEXTPTR := TPTR;
MAINCODE.LAST := TPTR;
TPTR↑.NEXTPTR := nil;
MAINCODE.NWORDS := MAINCODE.NWORDS + 1;
NEWCODEREC(TPTR)
end;
NEWINSTREC := TPTR
end (*EMIT_INSTR_OPNDS*);
procedure INSERT_INSTR_OPNDS(var WHERE : A_CODEREC; W1 : S1WORD;
var OPND1, OPND2 : OPERAND);
(*Common to EMIT routines. Fill in the short operand fields in W1,
insert a CODEREC containing W1 immediately following WHERE (at
front if WHERE = nil), and allocate and insert extended words if
needed. Return a pointer to the last CODEREC inserted in WHERE.
Update MAINCODE to reflect insertions. Does Not touch
NEWINSTREC.*)
var IPTR, NXPTR, TPTR, TTPTR : A_CODEREC;
begin
NEWCODEREC(IPTR);
if WHERE = nil then
begin
NXPTR := MAINCODE.FIRST;
MAINCODE.FIRST := IPTR
end
else (*WHERE <> nil*)
begin
if not (MAINCODE.FIRST<>nil) then ASSERTFAIL('INSERT_IN001');
NXPTR := WHERE↑.NEXTPTR;
WHERE↑.NEXTPTR := IPTR
end;
MAINCODE.NWORDS := MAINCODE.NWORDS + 1;
TPTR := IPTR;
if OPND2.X = 1 then
begin (*extended OPND2*)
NEWCODEREC(TTPTR);
TPTR↑.NEXTPTR := TTPTR;
MAINCODE.NWORDS := MAINCODE.NWORDS + 1;
TPTR := TTPTR
end
else TTPTR := nil;
BUILD_CW_OPERAND(W1,TTPTR,OPND2,OPND2_START);
if OPND1.X = 1 then
begin (*extended OPND1*)
NEWCODEREC(TTPTR);
TPTR↑.NEXTPTR := TTPTR;
MAINCODE.NWORDS := MAINCODE.NWORDS + 1;
TPTR := TTPTR
end
else TTPTR := nil;
BUILD_CW_OPERAND(W1,TTPTR,OPND1,OPND1_START);
IPTR↑.CODEWORD := W1;
TPTR↑.NEXTPTR := NXPTR;
if MAINCODE.LAST = WHERE then MAINCODE.LAST := TPTR;
WHERE := TPTR
end (*INSERT_INSTR_OPNDS*);
(** CODE_EMITTER_CLASS: EMITFAKEINST INSERTSOP INSERTJOP INSERTXOP EMIT_S1WORD EMIT_ZEROS1WORD **)
(**)
procedure EMITFAKEINST(* (FAKEOPC : S1OPCODE; FAKEOPND : integer) *); (*PBK*)
(*Emit the fake S1 instruction described.*)
begin
if not (OPFORMAT[FAKEOPC] = VFAKEOP) then ASSERTFAIL('EMITFAKEI001');
PUTFIELD(NEWINSTREC↑.CODEWORD,OPCODE_START,OPCODE_LEN,
HARDOPCODE[FAKEOPC]);
PUTFIELD(NEWINSTREC↑.CODEWORD,FAKEOPND_START,FAKEOPND_LEN,
FAKEOPND);
if MAINCODE.NWORDS = 0 then MAINCODE.FIRST := NEWINSTREC
else MAINCODE.LAST↑.NEXTPTR := NEWINSTREC;
NEWINSTREC↑.NEXTPTR := nil;
MAINCODE.LAST := NEWINSTREC;
MAINCODE.NWORDS := MAINCODE.NWORDS + 1;
NEWCODEREC(NEWINSTREC)
end (*EMITFAKEINST*);
procedure INSERTSOP(WHERE : A_CODEREC; S1OPC : S1OPCODE;
SKIPDIST : S1SKIPDISTANCE;
var OPND1, OPND2 : OPERAND;
SKIPDEST : A_CODEREC);
(*Insert the described SOP instruction after the coderec
that WHERE points to, updating MAINCODE to reflect changes.
Does not use NEWINSTREC. WHERE=nil means insert at front.*)
var WORD : S1WORD;
TPTR : A_CODEREC;
begin
if not ( OPFORMAT[S1OPC] = VSOP) then ASSERTFAIL('INSERTSOP001');
WORD := ZEROS1WORD;
PUTFIELD (WORD, OPCODE_START, OPCODE_LEN, HARDOPCODE[S1OPC]);
PUTFIELD (WORD, SKP_START, SKP_LEN, SKIPDIST);
INSERT_INSTR_OPNDS (WHERE, WORD, OPND1, OPND2);
NEWCODEREC (TPTR);
TPTR↑.NEXTPTR := WHERE↑.NEXTPTR;
WHERE↑.NEXTPTR := TPTR;
TPTR↑.CODEPTR := SKIPDEST;
MAINCODE.NWORDS := MAINCODE.NWORDS + 1;
if TPTR↑.NEXTPTR = nil then
MAINCODE.LAST := TPTR;
end (*INSERTSOP*);
procedure INSERTJOP(WHERE : A_CODEREC; S1OPC : S1OPCODE;
FORCELONG : BIT; var OPND1, OPND2 : OPERAND;
JUMPDEST : A_CODEREC);
(*Insert the described JOP instruction after the CODEREC that WHERE
points to, updating MAINCODE to reflect changes. Does Not use
NEWINSTREC. WHERE = nil means insert at front.*)
var WORD : S1WORD;
TPTR : A_CODEREC;
begin
if not (OPFORMAT[S1OPC] = VJOP) then ASSERTFAIL('INSERTJOP001');
WORD := ZEROS1WORD;
PUTFIELD(WORD,OPCODE_START,OPCODE_LEN,HARDOPCODE[S1OPC]);
PUTFIELD(WORD,PR_START,PR_LEN,FORCELONG);
INSERT_INSTR_OPNDS(WHERE,WORD,OPND1,OPND2);
NEWCODEREC(TPTR);
TPTR↑.NEXTPTR := WHERE↑.NEXTPTR;
WHERE↑.NEXTPTR := TPTR;
TPTR↑.CODEPTR := JUMPDEST;
MAINCODE.NWORDS := MAINCODE.NWORDS + 1;
if TPTR↑.NEXTPTR = nil then
MAINCODE.LAST := TPTR
end (*INSERTJOP*);
procedure INSERTXOP(WHERE : A_CODEREC; S1OPC : S1OPCODE;
var OPND1, OPND2 : OPERAND);
(*Insert the described XOP instruction after the coderec
that WHERE points to, updating MAINCODE to reflect changes.
Does not use NEWINSTREC. WHERE=nil means insert at front.*)
var WORD : S1WORD;
begin
if not ( OPFORMAT[S1OPC] = VXOP) then ASSERTFAIL('INSERTXOP001');
WORD := ZEROS1WORD;
PUTFIELD (WORD, OPCODE_START, OPCODE_LEN, HARDOPCODE[S1OPC]);
INSERT_INSTR_OPNDS (WHERE, WORD, OPND1, OPND2);
end (*INSERTSOP*);
procedure EMIT_S1WORD(var LIST : CODELIST; var W : S1WORD);
(*Add the word to the end of the codelist.*)
begin
if LIST.NWORDS = 0 then
begin
NEWCODEREC(LIST.FIRST);
LIST.LAST := LIST.FIRST;
LIST.NWORDS := 1
end
else
begin
NEWCODEREC(LIST.LAST↑.NEXTPTR);
LIST.LAST := LIST.LAST↑.NEXTPTR;
LIST.NWORDS := LIST.NWORDS + 1
end;
LIST.LAST↑.NEXTPTR := nil;
LIST.LAST↑.CODEWORD := W
end (*EMIT_S1WORD*);
procedure EMIT_ZEROS1WORD(var LIST : CODELIST;
var WHERE : A_CODEREC);
(*Add a zero S1WORD to the end of LIST, returning a pointer to it.*)
begin
if LIST.NWORDS = 0 then
begin
NEWCODEREC(LIST.FIRST);
LIST.LAST := LIST.FIRST;
LIST.NWORDS := 1
end
else
begin
NEWCODEREC(LIST.LAST↑.NEXTPTR);
LIST.LAST := LIST.LAST↑.NEXTPTR;
LIST.NWORDS := LIST.NWORDS + 1
end;
LIST.LAST↑.NEXTPTR := nil;
LIST.LAST↑.CODEWORD := ZEROS1WORD;
WHERE := LIST.LAST
end (*EMIT_ZEROS1WORD*);
(** CODE_EMITTER_CLASS: EMITSOP EMITJOP EMITTOP EMITXOP ALLOC_AND_EMIT_TOP **)
(**)
procedure EMITSOP(S1OPC : S1OPCODE; SKIPDIST : S1SKIPDISTANCE;
var OPND1, OPND2 : OPERAND; SKIPDEST : A_CODEREC);
(*Add described SOP instr, including extra word at the end for the
SKIPDEST, to the end of MAINCODE.*)
begin
if not (OPFORMAT[S1OPC] = VSOP) then ASSERTFAIL('EMITSOP 001');
PUTFIELD(NEWINSTREC↑.CODEWORD,OPCODE_START,OPCODE_LEN,
HARDOPCODE[S1OPC]);
PUTFIELD(NEWINSTREC↑.CODEWORD,SKP_START,SKP_LEN,SKIPDIST);
EMIT_INSTR_OPNDS(OPND1,OPND2);
MAINCODE.LAST↑.NEXTPTR := NEWINSTREC;
NEWINSTREC↑.NEXTPTR := nil;
MAINCODE.NWORDS := MAINCODE.NWORDS + 1;
MAINCODE.LAST := NEWINSTREC;
NEWCODEREC(NEWINSTREC);
MAINCODE.LAST↑.CODEPTR := SKIPDEST
end (*EMITSOP*);
procedure EMITJOP(S1OPC : S1OPCODE; FORCELONG : BIT;
var OPND1, OPND2 : OPERAND; JUMPDEST : A_CODEREC);
(*Add described JOP instr, including extra word at the end for the
JUMPDEST, to the end of MAINCODE. FORCELONG = 1 means that the
jump must be concretized into a two word instruction (or a one
word instr and a one word no-op). This bit of information is
stored for the time being in the PR field.*)
begin
if not (OPFORMAT[S1OPC] = VJOP) then ASSERTFAIL('EMITJOP 001');
PUTFIELD(NEWINSTREC↑.CODEWORD,OPCODE_START,OPCODE_LEN,
HARDOPCODE[S1OPC]);
PUTFIELD(NEWINSTREC↑.CODEWORD,PR_START,PR_LEN,FORCELONG);
EMIT_INSTR_OPNDS(OPND1,OPND2);
MAINCODE.LAST↑.NEXTPTR := NEWINSTREC;
NEWINSTREC↑.NEXTPTR := nil;
MAINCODE.NWORDS := MAINCODE.NWORDS + 1;
MAINCODE.LAST := NEWINSTREC;
NEWCODEREC(NEWINSTREC);
MAINCODE.LAST↑.CODEPTR := JUMPDEST
end (*EMITJOP*);
procedure EMITTOP(S1OPC : S1OPCODE; T : TWOBITS;
var OPND1, OPND2 : OPERAND);
(*Add described TOP instr to end of MAINCODE.*)
begin
if not (OPFORMAT[S1OPC] = VTOP) then ASSERTFAIL('EMITTOP 001');
PUTFIELD(NEWINSTREC↑.CODEWORD,OPCODE_START,OPCODE_LEN,
HARDOPCODE[S1OPC]);
PUTFIELD(NEWINSTREC↑.CODEWORD,T_START,T_LEN,T);
EMIT_INSTR_OPNDS(OPND1,OPND2);
end (*EMITTOP*);
procedure EMITXOP(*(S1OPC : S1OPCODE; var OPND1, OPND2 : OPERAND)*);
(*Add described XOP instr to end of MAINCODE.*)
begin
if not (OPFORMAT[S1OPC] = VXOP) then ASSERTFAIL('EMITXOP 001');
PUTFIELD(NEWINSTREC↑.CODEWORD,OPCODE_START,OPCODE_LEN,
HARDOPCODE[S1OPC]);
EMIT_INSTR_OPNDS(OPND1,OPND2);
end (*EMITXOP*);
procedure ALLOC_AND_EMIT_TOP(var R : S1REGISTER; OPCD : S1OPCODE;
var OPND1, OPND2 : OPERAND;
DOUBRES, DOUB1, DOUB2 : boolean;
STE : STKINX);
(*Allocate a register (returned in R) for the result of a TOP,
perhaps emitting a MOV to free it, and emit the TOP. Assume that
OPND1 and OPND2 regs were Not freed in advance, but will be freed
after return, being careful to not free reg R even if it
coincides with OPND1 or OPND2.
Note: DOUBRES, DOUB1, DOUB2 are true iff the result, opnd1,
and opnd2 respectively are doublewords. This can be deduced
from the opcode if the proper tables are declared.*)
var OPNDR : OPERAND;
MOVEOP : S1OPCODE;
begin
if not ( REVERSE_OP[OPCD]<>XILLEGAL) then ASSERTFAIL('ALLOC_AND001');
if IS_T_REG_NOT_RT(OPND1) and (DOUBRES <= DOUB1) then
begin
if IS_T_REG_NOT_RT(OPND2) and
(DOUBRES <= DOUB2) and (OPND2.F < OPND1.F) then
begin
R := OPND2.F;
EMITTOP (REVERSE_OP[OPCD], 0, OPND2, OPND1);
if DOUB2 and not DOUBRES then
begin
FREERG_S (R);
ALLOCRG (R);
end;
end
else
begin
R := OPND1.F;
EMITTOP (OPCD, 0, OPND1, OPND2);
if DOUB1 and not DOUBRES then
begin
FREERG_S (R);
ALLOCRG (R);
end;
end
end
else if IS_T_REG_NOT_RT(OPND2) and (DOUBRES <= DOUB2) then
begin
R := OPND2.F;
EMITTOP (REVERSE_OP[OPCD], 0, OPND2, OPND1);
if DOUB2 and not DOUBRES then
begin
FREERG_S (R);
ALLOCRG (R);
end;
end
else if IS_RTA(OPND1) then
begin
if DOUBRES then FINDRP else FINDRG;
R := NXTRG; REG_OPERAND (OPNDR, R);
EMITTOP (OPCD, 1, OPNDR, OPND2);
end
else if IS_RTA(OPND2) then
begin
if DOUBRES then FINDRP else FINDRG;
R := NXTRG; REG_OPERAND (OPNDR, R);
EMITTOP (REVERSE_OP[OPCD], 1, OPNDR, OPND1);
end
else if RISFREE[S1RTA] or USES_RTA(OPND1) or USES_RTA(OPND2) then
begin
if not RISFREE[S1RTA] then FREERG_S (S1RTA);
if DOUBRES then ALLOCRP(S1RTA) else ALLOCRG(S1RTA);
R := S1RTA;
EMITTOP (OPCD, 2, OPND1, OPND2);
end
else if RISFREE[S1RTB] or USES_RTB(OPND1) or USES_RTB(OPND2) then
begin
if not RISFREE[S1RTB] then FREERG_S (S1RTB);
if DOUBRES then ALLOCRP(S1RTB) else ALLOCRG(S1RTB);
RTBUSER := STE;
RTBDOUB := DOUBRES;
R := S1RTB;
EMITTOP (OPCD, 3, OPND1, OPND2);
end
else
begin (*if all else fails, emit a move*)
if DOUB1 or DOUBRES then FINDRP else FINDRG;
REG_OPERAND (OPNDR, NXTRG);
if DOUB1 then MOVEOP:=XMOV_D_D else MOVEOP:=XMOV_S_S;
EMITXOP (MOVEOP, OPNDR, OPND1);
R := NXTRG;
EMITTOP (OPCD, 0, OPNDR, OPND2);
if DOUB1 and not DOUBRES then
begin
FREERG_S (R);
ALLOCRG (R);
end;
end
end (*ALLOC_AND_EMIT_TOP*);
(** DATUM_PROCESSOR_CLASS: REG_DATUM COERCE_DATUM COERCE_TWO_DATUMS DATUM_IS_REG DATUM_IS_T_REG DATUM_IS_FILADR LOADSTACKEXCEPT BJUMP_TO_BINTVAL INCREMENT_DATUM **)
(**)
procedure GET_OPERAND (var OPND : OPERAND; STE : STKINX);
forward;
procedure FIT_IN_OPERAND (var TOO_COMPLICATED : boolean;
var OPND : OPERAND; STE : STKINX);
forward;
procedure MOVE_QUANTITY (var DEST : OPERAND; STE : STKINX);
forward;
procedure SIMPLIFY (STE : STKINX);
forward;
procedure ADD_SUB_SINGLE (var DEST : S1REGISTER; ADDOP : S1OPCODE;
var OPND1, OPND2 : OPERAND; STE : STKINX);
forward;
procedure REG_DATUM (STE : STKINX; RESCODESTART : A_CODEREC;
RESTYPE : OPNDTYPE; RESREG : S1REGISTER);
(*Build a datum in STK[STE] describing a quantity stored in a
given register, with a given CODESTART and DTYPE.*)
begin
with STK[STE] do
begin
STK[STE] := ZERODATUM;
CODESTART := RESCODESTART;
DTYPE := RESTYPE;
NVPAS := 1;
VPA1.VPA.WHICH := RGS;
VPA1.VPA.RGADR := RESREG;
end;
end (*REG_DATUM*);
procedure COERCE_DATUM(STE : STKINX; RTYPE : OPNDTYPE);
(*Perform an implicit type coercion of the datum STE to type RTYPE*)
var OPND, OPNDR : OPERAND;
MOVEOP : S1OPCODE;
begin
with STK[STE] do
if DTYPE <> RTYPE then
begin
MOVEOP := MOV_X_Y[RTYPE,DTYPE];
if MOVEOP = XILLEGAL then
ERROR(WINVALID_IMPLICIT_TYPE_COERCION);
if IS_CONSTANT(STE) then
if (DTYPE = TYPN) and (RTYPE = TYPA) then
(*leave TYPN alone, it's already TYPA (sort of)*)
else
DTYPE := RTYPE
else if DTYPE = TYPM then
begin
if not ( RTYPE = TYPA) then ASSERTFAIL('COERCE_DA001');
repeat SIMPLIFY(STE) until DTYPE = TYPA;
end
else
begin
GET_OPERAND(OPND,STE); FREEDATUMREGS(STE);
if IS_DOUBLE[RTYPE] then FINDRP else FINDRG;
REG_OPERAND(OPNDR,NXTRG);
EMITXOP(MOVEOP,OPNDR,OPND);
REG_DATUM(STE,CODESTART,RTYPE,NXTRG)
end
end
end (*COERCE_DATUM*);
procedure COERCE_TWO_DATUMS(var IS_OKTYPE :
OPNDTYPE_TO_BOOLEAN_ARRAY);
(*Instead of IS_OKTYPE, could possibly pass a set
of legal result types.*)
(*Take the top two datums on the stack, verify that they represent
acceptable types, and emit code to coerce them both to the same
result type.*)
var TYPE1, TYPE2, RTYPE : OPNDTYPE;
begin
TYPE1 := STK[TOP-1].DTYPE;
TYPE2 := STK[TOP].DTYPE;
if not IS_OKTYPE[TYPE1] or not IS_OKTYPE[TYPE2] then
ERROR(WBINARY_OPND_TYPE_CONFLICT);
RTYPE := ARITH_RESULT_TYPE[TYPE1,TYPE2];
if RTYPE = ILLARITH then
ERROR (WBINARY_OPND_TYPE_CONFLICT);
COERCE_DATUM(TOP-1,RTYPE);
COERCE_DATUM(TOP,RTYPE)
end (*COERCE_TWO_DATUMS*);
function DATUM_IS_REG (STE : STKINX) : boolean;
(*Return true iff datum specifies a quantity contained in a
register.*)
begin
DATUM_IS_REG := (STK[STE].FINALIND = IND0) and
(STK[STE].FPA = ZEROFPA) and
(STK[STE].DTYPE <> TYPM) and
( (STK[STE].DTYPE <> TYPB)
or (STK[STE].BREPRES = BINTVAL) ) and
(STK[STE].NVPAS = 1) and
(STK[STE].VPA1.VPAIND = IND1) and
(STK[STE].VPA1.VSHIFT = 0) and
(STK[STE].VPA1.VPA.WHICH = RGS);
end (*DATUM_IS_REG*);
function DATUM_IS_T_REG (STE : STKINX) : boolean;
(*Return true iff datum specifies a quantity contained in a
temporary register.*)
begin
DATUM_IS_T_REG := (STK[STE].FINALIND = IND0) and
(STK[STE].FPA = ZEROFPA) and
(STK[STE].DTYPE <> TYPM) and
( (STK[STE].DTYPE <> TYPB)
or (STK[STE].BREPRES = BINTVAL) ) and
(STK[STE].NVPAS = 1) and
(STK[STE].VPA1.VPAIND = IND1) and
(STK[STE].VPA1.VSHIFT = 0) and
(STK[STE].VPA1.VPA.WHICH = RGS) and
(*finally:*)
((STK[STE].VPA1.VPA.RGADR = S1RTA) or
(STK[STE].VPA1.VPA.RGADR = S1RTB) or
(MINTMPS1REG <= STK[STE].VPA1.VPA.RGADR) and
(STK[STE].VPA1.VPA.RGADR <= MAXTMPS1REG));
end (*DATUM_IS_T_REG*);
function DATUM_IS_FILADR (STE : STKINX) : boolean;
(*Return true iff datum specifies the quantity at P-Code
location <1,LCIOFILADR>. *)
begin
DATUM_IS_FILADR :=
(STK[STE].DTYPE = TYPA) and
(STK[STE].FINALIND = IND0) and
(STK[STE].FPA = ZEROFPA) and
(STK[STE].NVPAS = 1) and
(STK[STE].VPA1.VSHIFT = 0) and
(STK[STE].VPA1.VPAIND = IND1) and
(STK[STE].VPA1.VPA.WHICH = MEM) and
(STK[STE].VPA1.VPA.MEMADR.LVL = 1) and
(STK[STE].VPA1.VPA.MEMADR.DSPLMT
= LCIOFILADR - L1LOCALDATATRANSLATION);
end (*DATUM_IS_FILADR*);
procedure LOADSTACKEXCEPT (BOTEXC, TOPEXC : STKINX);
(*In order to prevent possible side effects because of standard
procedure calls or user procedure calls inside codeforks, we
call this procedure to load most items on the virtual stack into
temporary registers. Exceptions are constants (which are
completely in virtual form) and bjump booleans (which have no
storage associated with them that can be changed). There are
often stack entries, however, which we don't need or wish to
load in this way, because they are parameters which are being
passed or because we are about to throw them away anyway. The
range BOTEXC<=STE<=TOPEXC consists of such entries, and items in
that art of the stack are not loaded. Any DATUM which is a
file address is also not loaded. (A kludge so CHECKFILADR
will be able to tell which DATUMs are file addresses.) Later,
file addresses will be passed as parameters.*)
var OPNDR : OPERAND;
STE : STKINX;
R : S1REGISTER;
begin
for STE := BOT to TOP do
with STK[STE] do
if ((STE<BOTEXC) or (STE>TOPEXC)) and
(NVPAS>0) and
((DTYPE<>TYPB) or (BREPRES=BINTVAL)) and
not DATUM_IS_FILADR(STE) and
not DATUM_IS_T_REG(STE) then
begin (*generate a MOV*)
if IS_DOUBLE[DTYPE] then FINDRP else FINDRG;
R := NXTRG;
REG_OPERAND (OPNDR, R);
MOVE_QUANTITY (OPNDR, STE);
FREEDATUMREGS (STE);
REG_DATUM (STE, CODESTART, DTYPE, R);
end (*generate a MOV*);
end (*LOADSTACKEXCEPT*);
procedure BJUMP_TO_BINTVAL (STE : STKINX);
(*Convert the datum, which is a boolean in bjump form, into
bintval form.*)
(*This procedure probably could be done more easily simply by
loading a zero, then executing a conditional-skip tree which
may load a one at the end or may skip the load. LCW*)
var LOADFIRST : boolean;
FALLTHRUJUMP : A_CODEREC;
OPNDR, OPND2 : OPERAND;
TLOAD, FLOAD, SKIPLOC, CONTINUE : A_CODEREC;
P, NEXT : A_CODEREC;
begin
with STK[STE] do
begin
if not ((DTYPE=TYPB) and (BREPRES=BJUMP)) then
ASSERTFAIL('BJUMP_TO_001');
FALLTHRUJUMP := NEXT_INSTRUCTION(BFALLTHRUSKIPLOC);
if BTRUELIST.NWORDS < BFALSELIST.NWORDS then
LOADFIRST := (true)
else LOADFIRST := (false);
P := AFTER_LAST_XWORD(BFALLTHRUSKIPLOC);
P↑.NEXTPTR := NEXT_INSTRUCTION(P↑.NEXTPTR);
(*remove the fall-through jump*)
if LOADFIRST <> BJUMPON then
begin
INVERT_SKIP (BFALLTHRUSKIPLOC);
BJUMPON := not BJUMPON;
end;
REG_OPERAND (OPNDR, VPA1.VPA.RGADR);
(*Use the reg allocated to the bjump when created.*)
if LOADFIRST = (true) then
begin (*load true first*)
IMM_OPERAND (OPND2, 1);
INSERTXOP (P, XMOV_Q_Q, OPNDR, OPND2);
TLOAD := P↑.NEXTPTR;
P := TLOAD;
INSERTSOP (P, XSKP_EQL_Q, 0, ZERO_OP, ZERO_OP, nil);
SKIPLOC := P↑.NEXTPTR;
P := AFTER_LAST_XWORD(SKIPLOC);
INSERTXOP (P, XMOV_Q_Q, OPNDR, ZERO_OP);
FLOAD := P↑.NEXTPTR;
FIXSOP (BFALLTHRUSKIPLOC, FLOAD);
CONTINUE := NEXT_INSTRUCTION(FLOAD);
if CONTINUE <> nil then FIXSOP (SKIPLOC, CONTINUE)
else FIXSOP (SKIPLOC, NEWINSTREC);
end (*load true first*)
else
begin (*load false first*)
INSERTXOP (P, XMOV_Q_Q, OPNDR, ZERO_OP);
FLOAD := P↑.NEXTPTR;
P := FLOAD;
INSERTSOP (P, XSKP_EQL_Q, 0, ZERO_OP, ZERO_OP, nil);
SKIPLOC := P↑.NEXTPTR;
P := AFTER_LAST_XWORD(SKIPLOC);
IMM_OPERAND (OPND2, 1);
INSERTXOP (P, XMOV_Q_Q, OPNDR, OPND2);
TLOAD := P↑.NEXTPTR;
FIXSOP (BFALLTHRUSKIPLOC, TLOAD);
CONTINUE := NEXT_INSTRUCTION(TLOAD);
if CONTINUE <> nil then FIXSOP (SKIPLOC, CONTINUE)
else FIXSOP (SKIPLOC, NEWINSTREC);
end (*load false first*);
P := BTRUELIST.FIRST;
while P <> nil do
begin
NEXT := JUMPSKIPDEST(P);
FIXJOP (P, TLOAD);
P := NEXT;
end;
P := BFALSELIST.FIRST;
while P <> nil do
begin
NEXT := JUMPSKIPDEST(P);
FIXJOP (P, FLOAD);
P := NEXT;
end;
REG_DATUM (STE, CODESTART, TYPB, VPA1.VPA.RGADR);
BREPRES := BINTVAL;
end (*with STK[STE] do*)
end (*BJUMP_TO_BINTVAL*);
procedure INCREMENT_DATUM(STE : STKINX; INCR : integer); (*EJG*)
(*Increment the datum STE by the constant amount INCR*)
var
OLDTYPE : OPNDTYPE;
OPND1, OPND2 : OPERAND;
COMBINABLE, CALCULABLE : boolean;
TOOMUCH1 : boolean;
DEST : S1REGISTER;
begin
with STK[STE] do
begin
if not(DTYPE in
[TYPA, TYPB, TYPC, TYPM, TYPQ, TYPH, TYPI, TYPD]) then
ERROR (WNOT_DISCRETE_TYPE);
if INCR <> 0 then
begin
OLDTYPE := DTYPE;
if DTYPE in [TYPB, TYPC] then
begin
if (DTYPE=TYPB) and (BREPRES=BJUMP) then
BJUMP_TO_BINTVAL (STE);
DTYPE := TYPQ;
end;
if not(DTYPE in [TYPD, TYPA, TYPM]) then
COERCE_DATUM (STE, TYPI);
if DTYPE = TYPD then
begin
GET_OPERAND (OPND1, STE);
IMM_OPERAND (OPND2, INCR);
ALLOC_AND_EMIT_TOP (DEST, XADD_D, OPND1, OPND2,
true, true, true, STE);
FREEREGSBUTONE (STE, DEST);
REG_DATUM (STE, CODESTART, TYPD, DEST);
end (*TYPD*)
else
begin (*TYPI, TYPA, TYPM*)
COMBINABLE := false;
CALCULABLE := false;
repeat
if FINALIND = IND0 then COMBINABLE := true
else
begin
FIT_IN_OPERAND (TOOMUCH1, OPND1, STE);
if TOOMUCH1 then
SIMPLIFY (STE)
else
CALCULABLE := true;
end (*not combinable*);
until COMBINABLE or CALCULABLE;
if COMBINABLE then
FPA.MEMADR.DSPLMT := FPA.MEMADR.DSPLMT + INCR
else
begin (*calculable*)
IMM_OPERAND (OPND2, INCR);
ADD_SUB_SINGLE (DEST, XADD_S, OPND1, OPND2, STE);
FREEREGSBUTONE (STE, DEST);
REG_DATUM (STE, CODESTART, DTYPE, DEST);
end (*calculable*);
end (*TYPA, TYPI, TYPM*);
if OLDTYPE in [TYPB, TYPC] then
begin
COERCE_DATUM (STE, TYPQ);
DTYPE := OLDTYPE;
if DTYPE = TYPB then BREPRES := BINTVAL;
end;
end (*if INCR <> 0*);
end (*with STK[STE]*);
end (*INCREMENT_DATUM*);
(** DATUM_PROCESSOR_CLASS: BINTVAL_TO_BJUMP PARMREG_TO_PARMSAVE TRANSLATE_LVLDSP **)
(**)
procedure BINTVAL_TO_BJUMP (STE : STKINX);
(*Convert the datum, which is a boolean in bintval form,
into bjump form.*)
var OPND : OPERAND;
SKIPLOC : A_CODEREC;
RESCODESTART : A_CODEREC;
begin
with STK[STE] do
begin
if not ((DTYPE=TYPB) and (BREPRES=BINTVAL)) then
ASSERTFAIL('BINTVAL_T001');
GET_OPERAND (OPND, STE);
LOADSTACKEXCEPT (STE, STE);
if not RISFREE[S1RTB] and (RTBUSER <> STE) then
MOVE_AND_FREE_RTB;
FREEDATUMREGS (STE);
SKIPLOC := NEWINSTREC;
EMITSOP (XSKP_EQL_Q, 0, OPND, ZERO_OP, nil);
EMITJOP (XJMPA, 0, UNUSED_OP, ZERO_OP, nil);
FIXSOP (SKIPLOC, NEWINSTREC);
RESCODESTART := CODESTART;
STK[STE] := ZERODATUM;
CODESTART := RESCODESTART;
DTYPE := TYPB;
NVPAS := 1; (*make it not look like a constant. Not needed?*)
FINDRG;
VPA1.VPA.WHICH := RGS;
VPA1.VPA.RGADR := NXTRG;
(*where it will go if it becomes bintval*)
BREPRES := BJUMP;
BTRUELIST := EMPTYJUMPLIST;
BFALSELIST := EMPTYJUMPLIST;
BJUMPON := true;
BFALLTHRUSKIPLOC := SKIPLOC;
end (*with STK[STE] do*);
end (*BINTVAL_TO_BJUMP*);
procedure PARMREG_TO_PARMSAVE (STE : STKINX; PWORD : NONNEGINT);
(*If the datum contains references to parameter registers
logically preceding (but not including) parameter register
number 'PWORD', convert those references to the corresponding
location in the local parameter save area.*)
var P : integer;
begin
with NESTDISPLAY[CURLVL], STK[STE] do
if NVPAS>=1 then if VPA1.VPA.WHICH=RGS then if
IS_PARMREG(VPA1.VPA.RGADR) then if
S1REG_TO_PRM[VPA1.VPA.RGADR] < PWORD then
begin
P := S1REG_TO_PRM[VPA1.VPA.RGADR];
VPA1.VPA.WHICH := MEM;
VPA1.VPA.MEMADR.LVL := CURLVL;
VPA1.VPA.MEMADR.DSPLMT :=
-OFFSET_IN_VARS - SECONDPARMAREA - FIRSTPARMAREA
+ P*WORDUNITS;
if NVPAS>=2 then if VPA2.VPA.WHICH=RGS then if
IS_PARMREG(VPA2.VPA.RGADR) then if
S1REG_TO_PRM[VPA2.VPA.RGADR] < PWORD then
begin
P := S1REG_TO_PRM[VPA2.VPA.RGADR];
VPA2.VPA.WHICH := MEM;
VPA2.VPA.MEMADR.LVL := CURLVL;
VPA2.VPA.MEMADR.DSPLMT :=
-OFFSET_IN_VARS - SECONDPARMAREA - FIRSTPARMAREA
+ P*WORDUNITS;
end;
end;
end (*PARMREG_TO_PARMSAVE*);
procedure TRANSLATE_LVLDSP(var X : MEMOREG);
(*Translates a P-Code (LVL,DSPLMT) into an S1 (LVL,DSPLMT) or an
S1REGISTER.*)
var TMPLVL : 0..MAXLVL;
begin
if not (X.WHICH = MEM) then ASSERTFAIL('TRANSL_LV001');
if not (X.MEMADR.LVL <= CURLVL) then ASSERTFAIL('TRANSL_LV002');
TMPLVL := X.MEMADR.LVL;
with NESTDISPLAY[TMPLVL] do
begin
if X.MEMADR.DSPLMT <= FNCRSLT then
X.MEMADR.DSPLMT := X.MEMADR.DSPLMT - LOCALDATAOFFSET
else if (X.MEMADR.DSPLMT >= LCBEFPAR)
and (X.MEMADR.DSPLMT < LCBEFPAR+REGPARMAREA)
and (X.MEMADR.LVL = CURLVL) and (OPC <> PLDA) then
begin (*map local parm into its register*)
X.RGADR :=
PRM_TO_S1REG[(X.MEMADR.DSPLMT-LCBEFPAR) div WORDUNITS];
X.WHICH := RGS
end
else
X.MEMADR.DSPLMT := X.MEMADR.DSPLMT - LOCALDATATRANSLATION
end (*with NESTDISPLAY[TMPLVL] do*)
end (*TRANSLATE_LVLDSP*);
(** DATUM_PROCESSOR_CLASS: IS_SIMPLE FITS_SHRT_OFFSET FITS_SHORT_INDEX IS_CONSTANT IS_CONST_PLUS_OPND PUSHTOP POPTOP **)
(**)
function IS_SIMPLE (var V : VPAREC) : boolean;
(*Return true iff the VPA specifies an unshifted quantity
stored in a register.*)
begin
IS_SIMPLE := (V.VPAIND=IND1) and (V.VSHIFT=0)
and (V.VPA.WHICH=RGS);
end (*IS_SIMPLE*);
function FITS_SHRT_OFFSET (*(DISP : S1DISP) : boolean*);
(*Returns true iff the displacement is such that it
can be used in a short index.*)
begin
FITS_SHRT_OFFSET := (DISP mod WORDUNITS = 0)
and (MINSHORTOFFSET <= DISP div WORDUNITS)
and (DISP div WORDUNITS <= MAXSHORTOFFSET)
END (*FITS_SHRT_OFFSET*);
function FITS_SHORT_INDEX (var V : VPAREC) : boolean;
(*Returns true iff the VPA can be inserted as the
short index of an extended operand.*)
var D : INTEGER;
begin
if V.VPA.WHICH = RGS then FITS_SHORT_INDEX := true
else
begin
D := V.VPA.MEMADR.DSPLMT div WORDUNITS;
FITS_SHORT_INDEX := (V.VPAIND = IND1)
and (V.VPA.MEMADR.LVL > 0)
and (V.VPA.MEMADR.DSPLMT mod WORDUNITS = 0)
and (MINSHORTOFFSET <= D)
and (D <= MAXSHORTOFFSET)
end
end (*FITS_SHORT_INDEX*);
function IS_CONSTANT (*(STE : STKINX) : boolean*);
(*Return true iff datum represents a constant.*)
begin
IS_CONSTANT := (STK[STE].FINALIND = IND0)
and (STK[STE].NVPAS = 0)
and (STK[STE].FPA.WHICH = MEM)
and (STK[STE].DTYPE <> TYPM)
and ( (STK[STE].DTYPE <> TYPB)
or (STK[STE].BREPRES = BINTVAL) )
and (STK[STE].FPA.MEMADR.LVL = 0);
end (*IS_CONSTANT*);
function IS_CONST_PLUS_OPND (STE : STKINX) : boolean;
(*Return true iff datum represents a nonzero constant plus
other parts which will fit in an operand if the constant
part is excluded.*)
begin
IS_CONST_PLUS_OPND := (STK[STE].FINALIND = IND0)
and not (STK[STE].DTYPE in [TYPB, TYPM])
and (STK[STE].FPA.WHICH = MEM)
and (STK[STE].FPA.MEMADR.DSPLMT <> 0)
and ( (STK[STE].FPA.MEMADR.LVL=0) and (STK[STE].NVPAS=1)
and (STK[STE].VPA1.VSHIFT=0)
or (STK[STE].FPA.MEMADR.LVL<>0)
and (STK[STE].NVPAS=0) );
end (*IS_CONST_PLUS_OPND*);
procedure PUSHTOP;
(*Push an undefined datum onto the virtual stack,
checking for overflow.*)
begin
if TOP < MAXSTKINX then TOP := TOP + 1
else ERROR (WEXPR_TOO_COMPLEX);
end (*PUSHTOP*);
procedure POPTOP;
(*Pop the top value from the stack and discard it,
checking for underflow.*)
begin
if TOP >= BOT then TOP := TOP - 1
else ERROR (WPOP_OF_EMPTY_STACK);
end (*POPTOP*);
(** LITERAL_TABLE_CLASS: UPD_REALTBL UPD_SETTBL UPD_PROCTBL **)
(**)
procedure UPD_REALTBL (var DISP : S1DISP; RVAL : real);
(*Add the real to the real table if not already there. Return
its table displacement in DISP.*)
var FOUND : boolean;
PTR : A_CODEREC;
W : S1WORD;
begin
FOUND := false;
DISP := 0;
PTR := REALTBL.FIRST;
REAL_TO_S1WORD (W, RVAL);
while not FOUND and (PTR <> nil) do
if (PTR↑.CODEWORD = W) then
FOUND := true
else
begin
PTR := PTR↑.NEXTPTR↑.NEXTPTR;
DISP := DISP + WORDUNITS;
end;
if not FOUND then
begin
EMIT_S1WORD (REALTBL, W);
end;
end (*UPD_REALTBL*);
procedure UPD_SETTBL (var DISP : S1DISP; SVAL : SETREP);
(*Add the set to the set table if not already there. Return
its table displacement in DISP.*)
var FOUND : boolean;
PTR : A_CODEREC;
W1, W2 : S1WORD;
begin
FOUND := false;
DISP := 0;
PTR := SETTBL.FIRST;
SETREP_TO_S1WORDS (W1, W2, SVAL);
while not FOUND and (PTR <> nil) do
if (PTR↑.CODEWORD = W1) and (PTR↑.NEXTPTR↑.CODEWORD = W2) then
FOUND := true
else
begin
PTR := PTR↑.NEXTPTR↑.NEXTPTR;
DISP := DISP + 2*WORDUNITS;
end;
if not FOUND then
begin
EMIT_S1WORD (SETTBL, W1);
EMIT_S1WORD (SETTBL, W2);
end;
end (*UPD_SETTBL*);
procedure UPD_PROCTBL (var FIXPTR : A_PROCENT; var PID : ALFA);
(*Add the name in PID to the proc table if not already there and
return a pointer to the entry for fixup purposes.*)
var PTR : A_PROCENT;
begin
if PROCTBL.FIRST = nil then
begin
new (PROCTBL.FIRST);
with PROCTBL.FIRST↑ do
begin
NAME := PID; FIXLIST := EMPTYCODELIST; NEXTPTR := nil;
end;
PROCTBL.NPROCS := 1;
FIXPTR := PROCTBL.FIRST;
end
else
begin (*non-empty table*)
PTR := PROCTBL.FIRST;
while (PTR↑.NEXTPTR <> nil) and (PTR↑.NAME <> PID) do
PTR := PTR↑.NEXTPTR;
if PTR↑.NAME = PID then FIXPTR := PTR
else
begin (*add at end*)
new (PTR↑.NEXTPTR);
with PTR↑.NEXTPTR↑ do
begin
NAME := PID;
FIXLIST := EMPTYCODELIST;
NEXTPTR := nil;
end;
PROCTBL.NPROCS := PROCTBL.NPROCS + 1;
FIXPTR := PTR↑.NEXTPTR;
end (*add at end*);
end (*non-empty table*);
end (*UPD_PROCTBL*);
(** LITERAL_TABLE_CLASS: UPD_LBLTBL UPD_BOUNDTBL **)
(**)
procedure UPD_LBLTBL (*(var LPTR : A_LBLHASHENT; LNUM : LBL_INDEX;
LCLASS : LINTVAL_OR_LCODEPTR)*);
(*Add an entry for this label to the label hash table if one is not
already there. Return in LPTR a pointer to the entry.*)
var H : RNG_0_LBLHTSIZEM1;
PTR : A_LBLHASHENT;
FOUND : boolean;
begin
H := LABELHASH (LNUM);
PTR := LBLHASHTAB[H];
FOUND := false;
while not FOUND and (PTR <> nil) do
if PTR↑.LBLNUM = LNUM then FOUND := true
else PTR := PTR↑.NEXTPTR;
if FOUND then LPTR := PTR
else
begin (*add to front*)
new (PTR);
PTR↑.NEXTPTR := LBLHASHTAB[H];
LBLHASHTAB[H] := PTR;
PTR↑.LBLNUM := LNUM;
PTR↑.DEFINED := false;
case LCLASS of
LINTVAL : PTR↑.CLIST := EMPTYCODELIST;
LCODEPTR :
begin
PTR↑.JLIST := EMPTYJUMPLIST;
PTR↑.JUMPTABLELABEL := false
end
end (*case*);
LPTR := PTR;
end (*add to front*);
end (*UPD_LBLTBL*);
procedure UPD_BOUNDTBL (var DISP : S1DISP; LOW, HI : integer;
BNDTYP : OPNDTYPE);
(*Add the bound triple to the bound table if not already there.
Return its table displacement in DISP.*)
var FOUND : boolean;
PTR : A_CODEREC;
W1, W2, W3 : S1WORD;
begin
INTEGER_TO_S1WORD (W1, LOW);
INTEGER_TO_S1WORD (W2, HI);
W3 := ZEROS1WORD;
PUTFIELD (W3, BNDTYP_START, BNDTYP_LEN, ord(TYPECODE[BNDTYP]) );
PTR := BOUNDTBL.FIRST;
DISP := 0;
FOUND := false;
while not FOUND and (PTR <> nil) do
if (PTR↑.CODEWORD = W1) and (PTR↑.NEXTPTR↑.CODEWORD = W2) and
(PTR↑.NEXTPTR↑.NEXTPTR↑.CODEWORD = W3) then
FOUND := true
else
begin
PTR := PTR↑.NEXTPTR↑.NEXTPTR↑.NEXTPTR;
DISP := DISP + 3*WORDUNITS;
end;
if not FOUND then
begin
EMIT_S1WORD (BOUNDTBL, W1);
EMIT_S1WORD (BOUNDTBL, W2);
EMIT_S1WORD (BOUNDTBL, W3);
end;
end (*UPD_BOUNDTBL*);
(** GET_OPERAND_CLASS: INSERT_SHORT_VPA VPA_OPERAND_NOSHIFT FIT_IN_OPERAND **)
(**)
procedure INSERT_SHORT_VPA (var OPND : OPERAND;
var V : VPAREC);
(*Insert the VPA into the operand as a short index,
including shift, without changing the rest of
the operand.*)
begin
if not (FITS_SHORT_INDEX(V) and (OPND.X = 1) ) then
ASSERTFAIL('INS_SH_VP001');
if V.VPA.WHICH = RGS then
begin
if V.VPAIND = IND1 then
begin
OPND.REG := 0; OPND.F := V.VPA.RGADR
end
else
begin
OPND.REG := V.VPA.RGADR; OPND.F := 0
end
end (*register*)
else
begin (*short mem*)
OPND.REG := LVL_TO_S1REG [V.VPA.MEMADR.LVL];
OPND.F := V.VPA.MEMADR.DSPLMT div WORDUNITS
end (*short mem*);
OPND.XW.S := V.VSHIFT
end (*INSERT_SHORT_VPA*);
procedure VPA_OPERAND_NOSHIFT(var OPND : OPERAND; var V : VPAREC);
(*Construct an operand specifying the VPA, including indirection
but not including shift. Operand may be short or extended.*)
begin
if V.VPA.WHICH = RGS then
begin
OPND := EMPTY_OP;
OPND.X := 0;
if V.VPAIND = IND1 then
begin
OPND.REG := 0; OPND.F := V.VPA.RGADR
end
else
begin
OPND.REG := V.VPA.RGADR; OPND.F := 0
end
end (*register*)
else if FITS_SHRT_OFFSET(V.VPA.MEMADR.DSPLMT)
and (V.VPA.MEMADR.LVL > 0) then
begin
if V.VPAIND = IND2 then
ADDR_OPERAND (OPND, 0)
else
begin
OPND := EMPTY_OP;
OPND.X := 0
end;
OPND.REG := LVL_TO_S1REG [V.VPA.MEMADR.LVL];
OPND.F := V.VPA.MEMADR.DSPLMT div WORDUNITS
end (*short offset*)
else
begin (*extended address*)
if V.VPA.MEMADR.LVL = 0 then
ADDR_OPERAND (OPND, V.VPA.MEMADR.DSPLMT)
else
EXTENDED_REGDISP_OPERAND (OPND,
LVL_TO_S1REG [V.VPA.MEMADR.LVL],
V.VPA.MEMADR.DSPLMT);
if V.VPAIND = IND2 then OPND.XW.I := 1
end (*extended address*)
end (*VPA_OPERAND_NOSHIFT*);
procedure FIT_IN_OPERAND (*(var TOO_COMPLICATED : boolean;
var OPND : OPERAND; STE : STKINX)*);
(*Build an operand accessing the quantity described by the datum if
this is possible without emitting any code. Return
TOO_COMPLICATED = true if this was impossible, false
otherwise.*)
begin
TOO_COMPLICATED := false;
with STK[STE] do
begin
if not (FPA.WHICH = MEM) then ASSERTFAIL('FIT_IN_OP001');
if DTYPE = TYPM then TOO_COMPLICATED := true
else if IS_CONSTANT(STE) then
begin
if not (FINALIND = IND0) then ASSERTFAIL('FIT_IN_OP002');
if DTYPE in [TYPQ,TYPH,TYPI,TYPB,TYPC] then
IMM_OPERAND (OPND, FPA.MEMADR.DSPLMT)
else if DTYPE = TYPD then
begin
EXTENDED_IMM_OPERAND (OPND, FPA.MEMADR.DSPLMT);
OPND.F := 1; (*integer sign extend*)
end
else if DTYPE = TYPA then
begin
if (FPA.MEMADR.DSPLMT < 0) or
(FPA.MEMADR.DSPLMT > MAXS1ADDR) then
ERROR (WADDR_OUT_OF_RANGE);
IMM_OPERAND (OPND, FPA.MEMADR.DSPLMT)
end (*TYPA*)
else if DTYPE = TYPR then
REAL_IMM_OPERAND (OPND, RCNST) (*LCW*)
else if DTYPE = TYPS then
begin
EXTENDED_REGDISP_OPERAND
(OPND, S1RPC, 0);
OPND.FIXUP := SETFIX;
UPD_SETTBL (OPND.XW.DISP, PCNST);
end (*TYPS*)
else if DTYPE = TYPN then
IMM_OPERAND (OPND, NILVAL)
else if not (false) then ASSERTFAIL('FIT_IN_OP003');
end (*constant*)
else if FINALIND = IND0 then
case NVPAS of
(*NVPAS = *) 0:
if FPA.MEMADR.DSPLMT = 0 then
REG_OPERAND (OPND,
LVL_TO_S1REG[FPA.MEMADR.LVL])
else TOO_COMPLICATED := true;
(*NVPAS = *) 1:
if (VPA1.VSHIFT=0) and (FPA=ZEROFPA) then
VPA_OPERAND_NOSHIFT (OPND, VPA1)
else TOO_COMPLICATED := true;
(*NVPAS = *) 2:
TOO_COMPLICATED := true;
end (*case NVPAS of*)
else
begin (*FINALIND > IND0*)
if not ( NVPAS > 0) then ASSERTFAIL('FIT_IN_OP004');
if (FPA.MEMADR.LVL=0) and
(NVPAS=1) and IS_SIMPLE(VPA1) then
begin (*non-level register and displacement*)
if FINALIND = IND1 then
REGDISP_OPERAND (OPND, VPA1.VPA.RGADR,
FPA.MEMADR.DSPLMT)
else if FITS_SHRT_OFFSET(FPA.MEMADR.DSPLMT) then
begin
ADDR_OPERAND (OPND, 0);
OPND.REG := VPA1.VPA.RGADR;
OPND.F := FPA.MEMADR.DSPLMT div WORDUNITS
end
else
begin
EXTENDED_REGDISP_OPERAND (OPND,
VPA1.VPA.RGADR, FPA.MEMADR.DSPLMT);
OPND.XW.I := 1
end
end (*non-level register and displacement*)
else
begin (*more complicated*)
if NVPAS = 1 then
(*NVPAS = 1*)
begin
if not FITS_SHORT_INDEX(VPA1) then
TOO_COMPLICATED := true
else
begin
if FPA.MEMADR.LVL > 0 then
EXTENDED_REGDISP_OPERAND (OPND,
LVL_TO_S1REG [FPA.MEMADR.LVL],
FPA.MEMADR.DSPLMT)
else
ADDR_OPERAND (OPND, FPA.MEMADR.DSPLMT);
INSERT_SHORT_VPA (OPND, VPA1);
end
end (*NVPAS = 1*)
else
(*NVPAS = 2*)
if FPA.MEMADR.LVL > 0 then
TOO_COMPLICATED := true
else if IS_SIMPLE(VPA2) and
FITS_SHORT_INDEX(VPA1) then
begin
EXTENDED_REGDISP_OPERAND (OPND,
VPA2.VPA.RGADR, FPA.MEMADR.DSPLMT);
INSERT_SHORT_VPA (OPND, VPA1)
end
else if IS_SIMPLE(VPA1) and
FITS_SHORT_INDEX(VPA2) then
begin
EXTENDED_REGDISP_OPERAND (OPND,
VPA1.VPA.RGADR, FPA.MEMADR.DSPLMT);
INSERT_SHORT_VPA (OPND, VPA2)
end
else
TOO_COMPLICATED := true;
if FINALIND = IND2 then OPND.XW.I := 1;
end (*more complicated*)
end (*FINALIND > IND0*);
end (*with STK[STE] do*);
end (*FIT_IN_OPERAND*);
(** GET_OPERAND_CLASS: FIT_ADDRESS_IN_OPERAND **)
(**)
procedure FIT_ADDRESS_IN_OPERAND (var TOO_COMPLICATED : boolean;
var OPND : OPERAND; STE : STKINX);
(*Build an operand accessing the location whose address is the
quantity (of type address) described by the datum, if this is
possible without emitting any code. Return TOO_COMPLICATED =
true if this was impossible, false otherwise.*)
begin
TOO_COMPLICATED := false;
with STK[STE] do
begin
if (DTYPE=TYPM) or (FINALIND>IND1) then
TOO_COMPLICATED := true
else
case NVPAS of
(*NVPAS = *) 0:
begin
if not ( FINALIND = IND0) then ASSERTFAIL('FIT_ADDR 001');
if FPA.WHICH = RGS then
REG_OPERAND (OPND, FPA.RGADR)
else if FPA.MEMADR.LVL = 0 then
ADDR_OPERAND (OPND, FPA.MEMADR.DSPLMT)
else
REGDISP_OPERAND (OPND,
LVL_TO_S1REG [FPA.MEMADR.LVL],
FPA.MEMADR.DSPLMT)
end (*NVPAS = 0*);
(*NVPAS = *) 1:
begin
if (FPA.MEMADR.LVL = 0) and IS_SIMPLE(VPA1) then
begin (*non-level register and displacement*)
if FINALIND = IND0 then
REGDISP_OPERAND (OPND, VPA1.VPA.RGADR,
FPA.MEMADR.DSPLMT)
else if FITS_SHRT_OFFSET(FPA.MEMADR.DSPLMT) then
begin
ADDR_OPERAND (OPND, 0);
OPND.REG := VPA1.VPA.RGADR;
OPND.F := FPA.MEMADR.DSPLMT div WORDUNITS;
end
else
begin
EXTENDED_REGDISP_OPERAND (OPND,
VPA1.VPA.RGADR, FPA.MEMADR.DSPLMT);
OPND.XW.I := 1;
end;
end (*non-level register and displacement*)
else if FITS_SHORT_INDEX(VPA1) then
begin
if FPA.MEMADR.LVL = 0 then
ADDR_OPERAND (OPND, FPA.MEMADR.DSPLMT)
else
EXTENDED_REGDISP_OPERAND (OPND,
LVL_TO_S1REG [FPA.MEMADR.LVL],
FPA.MEMADR.DSPLMT);
INSERT_SHORT_VPA (OPND, VPA1);
if FINALIND = IND1 then OPND.XW.I := 1
end
else if (FINALIND=IND0) and (FPA=ZEROFPA) and
(VPA1.VSHIFT=0) and (VPA1.VPAIND=IND1) then
begin
VPA_OPERAND_NOSHIFT (OPND, VPA1);
if not ( OPND.X = 1) then ASSERTFAIL('FIT_ADDR 002');
OPND.XW.I := 1;
end
else
TOO_COMPLICATED := true;
end (*NVPAS = 1*);
(*NVPAS = *) 2:
begin
if FPA.MEMADR.LVL > 0 then
TOO_COMPLICATED := true
else if IS_SIMPLE(VPA1)
and FITS_SHORT_INDEX(VPA2) then
begin
EXTENDED_REGDISP_OPERAND (OPND,
VPA1.VPA.RGADR, FPA.MEMADR.DSPLMT);
INSERT_SHORT_VPA (OPND, VPA2);
if FINALIND = IND1 then OPND.XW.I := 1;
end
else if IS_SIMPLE(VPA2)
and FITS_SHORT_INDEX(VPA1) then
begin
EXTENDED_REGDISP_OPERAND (OPND,
VPA2.VPA.RGADR, FPA.MEMADR.DSPLMT);
INSERT_SHORT_VPA (OPND, VPA1);
if FINALIND = IND1 then OPND.XW.I := 1;
end
else
TOO_COMPLICATED := true
end (*NVPAS = 2*)
end (*case NVPAS*)
end (*with STK[STE]*)
end (*FIT_ADDRESS_IN_OPERAND*);
(** GET_OPERAND_CLASS: GET_OPERAND GET_SHORT_OPERAND GET_ADDRESS **)
(**)
procedure GET_OPERAND (*(var OPND : OPERAND; STE : STKINX)*);
(*Build an operand which accesses the quantity described
by the datum in STK[STE], simplifying the datum as
necessary.*)
var TOO_COMPLICATED : boolean;
begin
if STK[STE].DTYPE = TYPB then
if STK[STE].BREPRES = BJUMP then BJUMP_TO_BINTVAL (STE);
FIT_IN_OPERAND (TOO_COMPLICATED, OPND, STE);
while TOO_COMPLICATED do
begin
SIMPLIFY (STE);
FIT_IN_OPERAND (TOO_COMPLICATED, OPND, STE);
end;
end (*GET_OPERAND*);
procedure GET_SHORT_OPERAND (var OPND : OPERAND; STE : STKINX);
(*Build a short operand which accesses the quantity described
by the datum, simplifying as necessary.*)
var OPNDR : OPERAND;
begin
GET_OPERAND (OPND, STE);
if OPND.X = 1 then
begin (*generate a MOV*)
FREEDATUMREGS (STE);
if IS_DOUBLE[STK[STE].DTYPE] then FINDRP else FINDRG;
REG_OPERAND (OPNDR, NXTRG);
EMITXOP (MOV_X_X[STK[STE].DTYPE], OPNDR, OPND);
REG_DATUM (STE, STK[STE].CODESTART,
STK[STE].DTYPE, NXTRG);
OPND := OPNDR;
end (*generate a MOV*);
end (*GET_SHORT_OPERAND*);
procedure GET_ADDRESS (var OPND : OPERAND; STE : STKINX);
(*The datum describes a quantity of type address. Build an
operand accessing the location with that address,
simplifying the datum as necessary. (Approximately
GET_OPERAND with one more level of indirection
on the datum) *)
var TOO_COMPLICATED : boolean;
begin
FIT_ADDRESS_IN_OPERAND (TOO_COMPLICATED, OPND, STE);
while TOO_COMPLICATED do
begin
SIMPLIFY (STE);
FIT_ADDRESS_IN_OPERAND (TOO_COMPLICATED, OPND, STE);
end
end (*GET_ADDRESS*);
(** GET_OPERAND_CLASS: MOVE_QUANTITY SLR_QUANTITY COERCE_AND_MOVE_QUANTITY STORE **)
(**)
procedure MOVE_QUANTITY (*(var DEST : OPERAND; STE : STKINX)*);
(*Emit code to calculate the datum and move to location given
by operand. Do *Not* change datum to reflect move, but
simplification changes may take place.*)
var SOURCE : OPERAND;
TOOMUCH : boolean;
begin
with STK[STE] do
if (DTYPE=TYPA) and (FINALIND=IND0) then
begin
(*This attempts to optimize the case of an unindirected
address, without going to a lot of work. To do it
right every time would require a loop here like
the loops in the integer arithmetic instructions.*)
FIT_IN_OPERAND (TOOMUCH, SOURCE, STE);
if TOOMUCH then
begin
GET_ADDRESS (SOURCE, STE);
EMITXOP (XMOV_A, DEST, SOURCE);
end
else
EMITXOP (XMOV_S_S, DEST, SOURCE)
end
else
begin
GET_OPERAND (SOURCE, STE);
if DEST<>SOURCE then
EMITXOP (MOV_X_X[DTYPE], DEST, SOURCE);
end;
end (*MOVE_QUANTITY*);
procedure SLR_QUANTITY (DEST : OPERAND; REGNUM : S1REGISTER;
STE : STKINX);
(*Emit code to calculate the datum and load it into register REGNUM
while saving the previous contents of the register in the word
specified by the operand, using the SLR.'REGNUM' instruction.
Do *Not* change the datum to reflect the move, but
simplification changes may take place.*)
var SOURCE : OPERAND;
TOOMUCH : boolean;
begin
with STK[STE] do
if (DTYPE=TYPA) and (FINALIND=IND0) then
begin
(*This attempts to optimize the case of an unindirected
address, without going to a lot of work. To do it
right every time would require a loop here like
the loops in the integer arithmetic instructions.*)
FIT_IN_OPERAND (TOOMUCH, SOURCE, STE);
if TOOMUCH then
begin
GET_ADDRESS (SOURCE, STE);
EMITXOP (SLRADR_N[REGNUM], DEST, SOURCE);
end
else
EMITXOP (SLR_N[REGNUM], DEST, SOURCE)
end
else
begin
GET_OPERAND (SOURCE, STE);
EMITXOP (SLR_N[REGNUM], DEST, SOURCE);
end;
end (*SLR_QUANTITY*);
procedure COERCE_AND_MOVE_QUANTITY (var DEST : OPERAND;
STE : STKINX; RESTYPE : OPNDTYPE);
(*Get the datum to the location specified by the operand,
coercing it to type RESTYPE. Do *Not* change datum to
reflect coercion, but simplification changes may occur.*)
var SOURCE : OPERAND;
MOVEOP : S1OPCODE;
TOOMUCH : boolean;
begin
with STK[STE] do
if (DTYPE=TYPA) and (RESTYPE=TYPA) and (FINALIND=IND0) then
begin
(*This attempts to optimize the case of an unindirected
address, without going to a lot of work. To do it
right every time would require a loop here like
the loops in the integer arithmetic instructions.*)
FIT_IN_OPERAND (TOOMUCH, SOURCE, STE);
if TOOMUCH then
begin
GET_ADDRESS (SOURCE, STE);
EMITXOP (XMOV_A, DEST, SOURCE);
end
else
EMITXOP (XMOV_S_S, DEST, SOURCE)
end
else
begin
GET_OPERAND (SOURCE, STE);
if not EQUAL_OPERANDS(DEST,SOURCE) or (DTYPE<>RESTYPE)
then
begin (*Use ordinary MOV*)
MOVEOP := MOV_X_Y[RESTYPE, DTYPE];
if MOVEOP = XILLEGAL then
ERROR (WCOERCION_INVALID);
EMITXOP (MOVEOP, DEST, SOURCE);
end;
end (*Use ordinary MOV*);
end (*COERCE_AND_MOVE_QUANTITY*);
procedure STORE(DEST, SOURCE : STKINX);
(*For the future, consider doing STORE without always using
a MOV: (apropos for peephole).*)
(*Emit code to store the operand represented by SOURCE at the
address represented by DEST.*)
var OPND1 (*,OPND2*) : OPERAND;
MOVEOP : S1OPCODE;
begin
MOVEOP := MOV_X_Y[TYP,STK[SOURCE].DTYPE];
if MOVEOP = XILLEGAL then ERROR(WINCOMPATIBLE_TYPES);
(*Possible optimizing heuristic: GET_OPERAND before GET_ADDRESS*)
GET_ADDRESS(OPND1,DEST);
COERCE_AND_MOVE_QUANTITY(OPND1,SOURCE,TYP)
(*or, GET_OPERAND(OPND2,SOURCE); EMITXOP(MOVEOP,OPND1,OPND2)*)
end (*STORE*);
(** SIMPLIFY_CLASS: ADD_SUB_SINGLE INC_OR_DEC ADD_TOP_TWO_DATUMS MULT_SINGLE SIMPLIFY ADD_VPAS FPA_LVL_PLUS_VPA1 FPA_DSPLMT_PLUS_VPA1 VPA_FPA_FINALIND SHORT_AND_REG CALCULATE_FPA DEREF_AND_SHIFT SHIFT_VPA1 DEREF DEREF_TO_END **)
(**)
procedure ADD_SUB_SINGLE (*(var DEST : S1REGISTER; ADDOP : S1OPCODE;
var OPND1, OPND2 : OPERAND; STE : STKINX)*);
(*Add together the two singleword operands, optimizing
to INC or DEC if possible.*)
procedure INC_OR_DEC (INC : integer; var OPND : OPERAND);
var OPNDR : OPERAND;
ADDOP : S1OPCODE;
begin
if INC=1 then ADDOP:=XINC_S else ADDOP:=XDEC_S;
if IS_T_REG(OPND) then DEST := OPND.REG
else
begin
FINDRG; DEST := NXTRG
end;
REG_OPERAND (OPNDR, DEST);
EMITXOP (ADDOP, OPNDR, OPND);
end (*INC_OR_DEC*);
begin (*ADD_SUB_SINGLE*)
if ISSHORTCONST(OPND1) and ((OPND1.F=1) or (OPND1.F=-1)) then
if ADDOP=XADD_S then INC_OR_DEC(OPND1.F, OPND2)
else INC_OR_DEC(-OPND1.F, OPND2)
else if ISSHORTCONST(OPND2) and ((OPND2.F=1) or (OPND2.F=-1)) then
if ADDOP=XADD_S then INC_OR_DEC(OPND2.F, OPND1)
else INC_OR_DEC(-OPND2.F, OPND1)
else
ALLOC_AND_EMIT_TOP (DEST, ADDOP, OPND1, OPND2,
false, false, false, STE);
end (*ADD_SUB_SINGLE*);
procedure ADD_TOP_TWO_DATUMS;
(*Add the top two singlewords (integer or address) on the
stack by combining and/or emitting code. Sets DTYPE and
CODESTART in the resultant datum.*)
var COMBINABLE, ADDABLE, TOOMUCH1, TOOMUCH2 : boolean;
CONSTPART : integer;
OPND1, OPND2 : OPERAND;
UNSIMPLE, SIMPLER : STKINX;
DEST : S1REGISTER;
RESTYPE : OPNDTYPE;
begin
COMBINABLE := false;
ADDABLE := false;
repeat
if (STK[TOP].NVPAS=0) and (STK[TOP].FPA=ZEROFPA)
and (STK[TOP].DTYPE<>TYPM) then
COMBINABLE := true
else if (STK[TOP-1].NVPAS=0) and (STK[TOP-1].FPA=ZEROFPA)
and (STK[TOP-1].DTYPE<>TYPM) then
COMBINABLE := true
else
if (STK[TOP].FINALIND=IND0) and (STK[TOP-1].FINALIND=IND0)
and ( ((STK[TOP].FPA.MEMADR.LVL=0) and (STK[TOP].DTYPE<>TYPM))
or ((STK[TOP-1].FPA.MEMADR.LVL=0)
and (STK[TOP-1].DTYPE<>TYPM)) )
and (STK[TOP].NVPAS + STK[TOP-1].NVPAS <= 2) then
COMBINABLE := true
else
begin (*not combinable*)
if (STK[TOP].FINALIND = IND0) and
(STK[TOP-1].FINALIND = IND0) then
begin
CONSTPART := STK[TOP].FPA.MEMADR.DSPLMT
+ STK[TOP-1].FPA.MEMADR.DSPLMT;
STK[TOP].FPA.MEMADR.DSPLMT := 0;
STK[TOP-1].FPA.MEMADR.DSPLMT := 0;
end
else
CONSTPART := 0;
FIT_IN_OPERAND (TOOMUCH1, OPND1, TOP-1);
FIT_IN_OPERAND (TOOMUCH2, OPND2, TOP);
if not TOOMUCH1 and not TOOMUCH2 then
ADDABLE := true
else
begin (*must simplify*)
if not TOOMUCH1 then
begin
UNSIMPLE := TOP;
SIMPLER := TOP-1;
end
else if not TOOMUCH2 then
begin
UNSIMPLE := TOP-1;
SIMPLER := TOP;
end
else
begin (*Pick one at random*)
UNSIMPLE := TOP;
SIMPLER := TOP-1;
end;
if CONSTPART <> 0 then
begin
if not ((STK[UNSIMPLE].FINALIND = IND0) and
(STK[UNSIMPLE].FPA.MEMADR.DSPLMT = 0) ) then
ASSERTFAIL('ADD_TOP_T001');
STK[UNSIMPLE].FPA.MEMADR.DSPLMT := CONSTPART;
end;
SIMPLIFY (UNSIMPLE);
end (*must simplify*);
end (*not combinable*)
until COMBINABLE or ADDABLE;
if (STK[TOP-1].DTYPE=TYPM) or (STK[TOP].DTYPE=TYPM) then
RESTYPE := TYPM
else if (STK[TOP-1].DTYPE=TYPA) or (STK[TOP].DTYPE=TYPA) then
RESTYPE := TYPA
else RESTYPE := TYPI;
if ADDABLE then
begin (*ADDABLE*)
ADD_SUB_SINGLE (DEST, XADD_S, OPND1, OPND2, TOP-1);
FREEREGSBUTONE (TOP, DEST);
POPTOP;
FREEREGSBUTONE (TOP, DEST);
REG_DATUM (TOP, STK[TOP].CODESTART, RESTYPE, DEST);
STK[TOP].DTYPE := RESTYPE;
end (*ADDABLE*)
else
begin (*COMBINABLE*)
if (STK[TOP-1].NVPAS=0) and
(STK[TOP-1].FPA=ZEROFPA) and (STK[TOP-1].DTYPE<>TYPM) then
STK[TOP-1] := STK[TOP]
else if (STK[TOP].NVPAS=0) and
(STK[TOP].FPA=ZEROFPA) and (STK[TOP].DTYPE<>TYPM) then
(*Top is zero so just throw it away.*)
else
begin (*Both datums have FINALIND = IND0.*)
if STK[TOP].FPA.MEMADR.LVL<>0 then
STK[TOP-1].FPA.MEMADR.LVL := STK[TOP].FPA.MEMADR.LVL;
STK[TOP-1].FPA.MEMADR.DSPLMT :=
STK[TOP].FPA.MEMADR.DSPLMT +
STK[TOP-1].FPA.MEMADR.DSPLMT;
if STK[TOP-1].NVPAS = 0 then
begin
if STK[TOP].NVPAS > 0 then
STK[TOP-1].VPA1 := STK[TOP].VPA1;
if STK[TOP].NVPAS = 2 then
STK[TOP-1].VPA2 := STK[TOP].VPA2;
end
else if (STK[TOP-1].NVPAS=1) and (STK[TOP].NVPAS=1) then
STK[TOP-1].VPA2 := STK[TOP].VPA1;
STK[TOP-1].NVPAS := STK[TOP-1].NVPAS+STK[TOP].NVPAS;
end (*Both datums have FINALIND = IND0*);
if RTBUSER = TOP then RTBUSER := TOP-1;
POPTOP;
end (*COMBINABLE*);
end (*ADD_TOP_TWO_DATUMS*);
procedure MULT_SINGLE (var DEST : S1REGISTER;
var OPND1, OPND2 : OPERAND; STE : STKINX);
(*Multiply together the two singleword operands, optimizing to
shift if possible. Note that because of negatives, a right
shift is *Not* equivalent to a divide.*)
(*Note - at present this procedure only considers short
constants for possible translations into shifts.
When real S1WORDs make it easier to consider extended
constants, this should be improved.*)
var SHIFTDIST : integer;
OPNDI : OPERAND;
begin
if ISSHORTCONST(OPND1) then
begin
SHIFTDIST := POWER2 (OPND1.F);
if SHIFTDIST >= 0 then
begin
IMM_OPERAND (OPNDI, SHIFTDIST);
ALLOC_AND_EMIT_TOP (DEST, XSHFA_LF_S, OPND2, OPNDI,
false, false, false, STE);
end
else
ALLOC_AND_EMIT_TOP (DEST, XMULT_S, OPND1, OPND2,
false, false, false, STE);
end
else if ISSHORTCONST(OPND2) then
begin
SHIFTDIST := POWER2 (OPND2.F);
if SHIFTDIST >= 0 then
begin
IMM_OPERAND (OPNDI, SHIFTDIST);
ALLOC_AND_EMIT_TOP
(DEST, XSHFA_LF_S, OPND1, OPNDI,
false, false, false, STE);
end
else
ALLOC_AND_EMIT_TOP (DEST, XMULT_S, OPND1, OPND2,
false, false, false, STE);
end
else
ALLOC_AND_EMIT_TOP (DEST, XMULT_S, OPND1, OPND2,
false, false, false, STE);
end (*MULT_SINGLE*);
procedure SIMPLIFY (*(STE : STKINX)*);
(*By doing a very small amount of work - about one instruction -
simplify the datum so that it is closer to fitting in an
operand. Repeated calls to this procedure are guaranteed to
eventually get it so it will fit. One more call will get the
quantity into a register if it is not a constant: beyond this
point it is an error to call SIMPLIFY.*)
var OPND : OPERAND;
UNKNOWN_LOC : integer;
procedure ADD_VPAS;
(*Build operands for VPA1 and VPA2, both of which have zero
shifts. Generate an ADD instruction to combine the two
into a simple register. This is guaranteed not to
completely sum the parts of the datum if the datum is
an address.*)
var OPND1, OPND2 : OPERAND;
DEST : S1REGISTER;
begin
with STK[STE] do
begin
if not ((VPA1.VSHIFT=0) and (VPA2.VSHIFT=0)) then
ASSERTFAIL('ADD_VPAS 001');
if not ((FINALIND>IND0) or (DTYPE in [TYPA,TYPM,TYPI])) then
ASSERTFAIL('ADD_VPAS 002');
VPA_OPERAND_NOSHIFT (OPND1, VPA1);
VPA_OPERAND_NOSHIFT (OPND2, VPA2);
ALLOC_AND_EMIT_TOP (DEST, XADD_S, OPND1, OPND2,
false, false, false, STE);
FREEVPARGUNLESS (VPA1, DEST);
FREEVPARGUNLESS (VPA2, DEST);
VPA1 := ZEROVPA; VPA2 := ZEROVPA;
NVPAS := 1;
VPA1.VPA.WHICH := RGS;
VPA1.VPA.RGADR := DEST;
end (*with STK[STE]*)
end (*ADD_VPAS*);
procedure FPA_LVL_PLUS_VPA1 (var OPND : OPERAND);
(*OPND describes VPA1. Emit an ADD instruction to
combine this with the FPA level, replacing them
by a simple register. This is guaranteed not to
completely sum the parts of the datum.*)
var OPND2 : OPERAND;
DEST : S1REGISTER;
begin
with STK[STE] do
begin
if not ((FPA.MEMADR.LVL > 0) and
((DTYPE=TYPA) or (FINALIND>IND0)) ) then
ASSERTFAIL('FPLVL_VPA001');
REG_OPERAND (OPND2, LVL_TO_S1REG [FPA.MEMADR.LVL] );
ALLOC_AND_EMIT_TOP (DEST, XADD_S, OPND, OPND2,
false, false, false, STE);
FREEVPARGUNLESS (VPA1, DEST);
VPA1 := ZEROVPA;
FPA.MEMADR.LVL := 0;
VPA1.VPA.WHICH := RGS;
VPA1.VPA.RGADR := DEST;
end (*with STK[STE]*)
end (*FPA_LVL_PLUS_VPA1*);
procedure FPA_DSPLMT_PLUS_VPA1 (var OPND : OPERAND);
(*OPND describes VPA1. Emit an ADD instruction
to add this VPA to the FPA displacement,
resulting in a single register VPA.*)
var OPND2 : OPERAND;
DEST : S1REGISTER;
begin
with STK[STE] do
begin
if not ((FINALIND=IND0) and (DTYPE=TYPI)) then
ASSERTFAIL('FDSP_VPA 001');
IMM_OPERAND (OPND2, FPA.MEMADR.DSPLMT);
ADD_SUB_SINGLE (DEST, XADD_S, OPND, OPND2, STE);
FREEVPARGUNLESS (VPA1, DEST);
FPA.MEMADR.DSPLMT := 0;
VPA1 := ZEROVPA;
VPA1.VPA.WHICH := RGS;
VPA1.VPA.RGADR := DEST
end (*with STK[STE]*)
end (*FPA_DSPLMT_PLUS_VPA1*);
procedure VPA_FPA_FINALIND;
(*The datum consists of a short-index VPA and an FPA,
with some value of FINALIND. Completely simplify it
using address arithmetic into a single register.*)
var OPND1, OPND2 : OPERAND;
MOVEOP : S1OPCODE;
begin
with STK[STE] do
if IS_SIMPLE(VPA1) and (DTYPE<>TYPM)
and (FPA.MEMADR.LVL = 0)
and FITS_SHRT_OFFSET (FPA.MEMADR.DSPLMT) then
begin (*non-level register and short offset*)
if FINALIND = IND2 then
begin
ADDR_OPERAND (OPND2, 0);
OPND2.REG := VPA1.VPA.RGADR;
OPND2.F := FPA.MEMADR.DSPLMT div WORDUNITS;
FREEDATUMREGS (STE);
MOVEOP := MOV_X_X[DTYPE];
if IS_DOUBLE[DTYPE] then FINDRP else FINDRG;
end
else
begin
REGDISP_OPERAND (OPND2, VPA1.VPA.RGADR,
FPA.MEMADR.DSPLMT);
FREEDATUMREGS (STE);
if FINALIND = IND0 then
begin MOVEOP := XMOV_A; FINDRG; end
else
begin
MOVEOP := MOV_X_X[DTYPE];
if IS_DOUBLE[DTYPE] then FINDRP else FINDRG;
end;
end;
REG_DATUM (STE, CODESTART, DTYPE, NXTRG);
REG_OPERAND (OPND1, NXTRG);
EMITXOP (MOVEOP, OPND1, OPND2);
end (*non-level register and short offset*)
else
begin
if not (((DTYPE in [TYPA,TYPM]) or (FINALIND>IND0))
and (NVPAS=1) and FITS_SHORT_INDEX(VPA1) ) then
ASSERTFAIL('VP_FP_FIN001');
if FPA.MEMADR.LVL > 0 then
EXTENDED_REGDISP_OPERAND (OPND2,
LVL_TO_S1REG [FPA.MEMADR.LVL],
FPA.MEMADR.DSPLMT)
else if DTYPE <> TYPM then
ADDR_OPERAND (OPND2, FPA.MEMADR.DSPLMT)
else
begin
EXTENDED_REGDISP_OPERAND (OPND2,
S1RPC, FPA.MEMADR.DSPLMT);
OPND2.FIXUP := STRINGFIX;
DTYPE := TYPA;
end;
INSERT_SHORT_VPA (OPND2, VPA1);
FREEDATUMREGS (STE);
if FINALIND = IND0 then
begin
MOVEOP := XMOV_A; FINDRG
end
else
begin
MOVEOP := MOV_X_X[DTYPE];
if IS_DOUBLE[DTYPE] then FINDRP else FINDRG;
if FINALIND = IND2 then OPND2.XW.I := 1;
end;
REG_DATUM (STE, CODESTART, DTYPE, NXTRG);
REG_OPERAND (OPND1, NXTRG);
EMITXOP (MOVEOP, OPND1, OPND2);
end (*with STK[STE]*)
end (*VPA_FPA_FINALIND*);
procedure SHORT_AND_REG (var VSHORT, VREG : VPAREC);
(*Combine the two VPAs and the FPA displacement into
a simple register by address arithmetic. Allow
for the possibility that this may completely sum
the parts; in that case include FINALIND in the
operand to completely simplify the datum. Note
that the FPA level may be implicit due to DTYPE=TYPM.*)
var OPND1, OPND2 : OPERAND;
MOVEOP : S1OPCODE;
begin
with STK[STE] do
begin
if not ((DTYPE in [TYPA,TYPM]) or (FINALIND > IND0) ) then
ASSERTFAIL('SHORT®001');
EXTENDED_REGDISP_OPERAND (OPND2,
VREG.VPA.RGADR, FPA.MEMADR.DSPLMT);
INSERT_SHORT_VPA (OPND2, VSHORT);
FPA.MEMADR.DSPLMT := 0;
FREEVPAREG (VPA1);
FREEVPAREG (VPA2);
VPA1 := ZEROVPA; VPA2 := ZEROVPA;
NVPAS := 1;
if (FINALIND=IND0) or
(FPA.MEMADR.LVL>0) or (DTYPE=TYPM) then
begin
MOVEOP := XMOV_A; FINDRG
end
else
begin
MOVEOP := MOV_X_X [DTYPE];
if IS_DOUBLE [DTYPE] then FINDRP else FINDRG;
if FINALIND = IND2 then OPND2.XW.I := 1;
FINALIND := IND0;
end;
VPA1.VPA.WHICH := RGS;
VPA1.VPA.RGADR := NXTRG;
REG_OPERAND (OPND1, NXTRG);
EMITXOP (MOVEOP, OPND1, OPND2);
end (*with STK[STE]*)
end (*SHORT_AND_REG*);
procedure CALCULATE_FPA;
(*Combine the FPA level and displacement by address
arithmetic. The level may be implicitly PC-relative
by virtue of the datum's being TYPM. Assume no
VPAs and FINALIND = IND0.*)
var OPND1, OPND2 : OPERAND;
begin
with STK[STE] do
begin
if not ((DTYPE in [TYPA,TYPM]) and
(NVPAS=0) and (FINALIND=IND0) ) then
ASSERTFAIL('CALC_FPA 001');
FINDRG;
REG_OPERAND (OPND1, NXTRG);
if DTYPE <> TYPM then
REGDISP_OPERAND (OPND2,
LVL_TO_S1REG [FPA.MEMADR.LVL],
FPA.MEMADR.DSPLMT)
else
begin
EXTENDED_REGDISP_OPERAND
(OPND2, S1RPC, FPA.MEMADR.DSPLMT);
OPND2.FIXUP := STRINGFIX;
DTYPE := TYPA;
end;
FPA := ZEROFPA;
NVPAS := 1;
VPA1.VPA.WHICH := RGS;
VPA1.VPA.RGADR := NXTRG;
EMITXOP (XMOV_A, OPND1, OPND2);
end (*with STK[STE]*)
end (*CALCULATE_FPA*);
procedure DEREF_AND_SHIFT (var V : VPAREC);
(*Build an operand from the VPA neglecting shift and
emit a SHIFT instruction to reduce the VPA to
a simple register.*)
var OPND1, OPND2 : OPERAND;
DEST : S1REGISTER;
begin
with STK[STE] do
if not ((FINALIND>IND0) or (DTYPE in [TYPA,TYPM,TYPI]) ) then
ASSERTFAIL('DEREFSHFT001');
VPA_OPERAND_NOSHIFT (OPND1, V);
IMM_OPERAND (OPND2, V.VSHIFT);
ALLOC_AND_EMIT_TOP (DEST, XSHFA_LF_S, OPND1, OPND2,
false, false, false, STE);
FREEVPARGUNLESS (V, DEST);
V := ZEROVPA;
V.VPA.WHICH := RGS;
V.VPA.RGADR := DEST;
end (*DEREF_AND_SHIFT*);
PROCEDURE SHIFT_VPA1 (var OPND : OPERAND);
(*OPND describes VPA1. Emit a SHIFT instruction to
reduce VPA1 to a simple register.*)
var OPND2 : OPERAND;
DEST : S1REGISTER;
begin
with STK[STE] do
begin
if not ((FINALIND>IND0) or (DTYPE in [TYPA,TYPM,TYPI]) ) then
ASSERTFAIL('SHIFTVPA 001');
IMM_OPERAND (OPND2, VPA1.VSHIFT);
ALLOC_AND_EMIT_TOP (DEST, XSHFA_LF_S, OPND, OPND2,
false, false, false, STE);
FREEVPARGUNLESS (VPA1, DEST);
VPA1 := ZEROVPA;
VPA1.VPA.WHICH := RGS;
VPA1.VPA.RGADR := DEST;
end (*with STK[STE]*)
end (*SHIFT_VPA1*);
PROCEDURE DEREF (var V : VPAREC; var OPND : OPERAND);
(*OPND describes the VPA, posibly with additional
indirection. Generate a MOV using this operand,
which will reduce the VPA to a simple register without
completely simplifying the datum. (Both these
conditions are assured by the caller.)*)
var OPNDR : OPERAND;
begin
FREEVPAREG (V);
FINDRG;
REG_OPERAND (OPNDR, NXTRG);
EMITXOP (XMOV_S_S, OPNDR, OPND);
V := ZEROVPA;
V.VPA.WHICH := RGS;
V.VPA.RGADR := NXTRG
end (*DEREF*);
PROCEDURE DEREF_TO_END (var V : VPAREC;
var OPND : OPERAND; DTYPE : OPNDTYPE);
(*OPND describes the VPA, possibly with some extra
indirection. Generate a MOV using this operand to
reduce the VPA to a simple register. This operation
is guaranteed to completely simplify the datum, which
is of type DTYPE.*)
var OPNDR : OPERAND;
begin
FREEVPAREG (V);
if IS_DOUBLE [DTYPE] then FINDRP else FINDRG;
REG_OPERAND (OPNDR, NXTRG);
EMITXOP (MOV_X_X[DTYPE], OPNDR, OPND);
V := ZEROVPA;
V.VPA.WHICH := RGS;
V.VPA.RGADR := NXTRG;
end (*DEREF_TO_END*);
begin (*SIMPLIFY*)
with STK[STE] do
begin
if FPA.WHICH = RGS then
ERROR (WINDEXING_IN_PARMS);
if (FINALIND=IND0) and not(DTYPE in [TYPA,TYPM]) then
begin (*no address arithmetic allowed*)
if not ( FPA.MEMADR.LVL = 0) then ASSERTFAIL('SIMPLIFY 001');
case NVPAS of
(*NVPAS = *) 0:
if not ( false) then ASSERTFAIL('SIMPLIFY 002');
(*NVPAS = *) 1:
begin
VPA_OPERAND_NOSHIFT (OPND, VPA1);
if VPA1.VSHIFT > 0 then
SHIFT_VPA1 (OPND)
else if FPA.MEMADR.DSPLMT <> 0 then
FPA_DSPLMT_PLUS_VPA1 (OPND)
else
begin
if not ( not IS_SIMPLE(VPA1) ) then
ASSERTFAIL('SIMPLIFY 003');
DEREF_TO_END (VPA1, OPND, DTYPE);
end
end (*NVPAS = 1*);
(*NVPAS = *) 2:
if VPA1.VSHIFT > 0 then
DEREF_AND_SHIFT (VPA1)
else if VPA2.VSHIFT > 0 then
DEREF_AND_SHIFT (VPA2)
else
ADD_VPAS;
end (*case NVPAS*);
end (*no address arithmetic allowed*)
else
begin (*address arithmetic allowed. In fact, to
prevent an address from looking like an
indirect address pointer, address arithmetic
is required if a non-address operation
would completely simplify the datum.*)
case NVPAS of
(*NVPAS = *) 0:
begin
if not ((DTYPE = TYPM) or
(FPA.MEMADR.LVL>0) and (FPA.MEMADR.DSPLMT<>0) ) then
ASSERTFAIL('SIMPLIFY 004');
CALCULATE_FPA
end (*NVPAS = 0*);
(*NVPAS = *) 1:
begin
if not (not ((DTYPE<>TYPM) and (FPA=ZEROFPA) and
IS_SIMPLE(VPA1) ) ) then
ASSERTFAIL('SIMPLIFY 005');
if FITS_SHORT_INDEX (VPA1) then
VPA_FPA_FINALIND
else
begin (*requires extended address*)
VPA_OPERAND_NOSHIFT (OPND, VPA1);
if VPA1.VSHIFT > 0 then
begin
if (FPA=ZEROFPA) and (DTYPE<>TYPM) then
ERROR (WINDEX_WITHOUT_BASE);
SHIFT_VPA1 (OPND)
end
else if (FPA.MEMADR.LVL>0)
and (FPA.MEMADR.DSPLMT<>0) then
FPA_LVL_PLUS_VPA1 (OPND)
else if (DTYPE=TYPM) or (FPA<>ZEROFPA) then
DEREF (VPA1, OPND)
else
begin (*dereference some or all the way*)
if not ( OPND.X = 1) then ASSERTFAIL('SIMPLIFY 006');
if (FINALIND>IND0) and (OPND.XW.I=0) then
begin
OPND.XW.I := 1;
FINALIND := pred(FINALIND);
end;
if FINALIND = IND0 then
DEREF_TO_END (VPA1, OPND, DTYPE)
else
begin
DEREF (VPA1, OPND);
VPA1.VPAIND := IND2;
FINALIND := pred(FINALIND)
end;
end (*dereference*)
end (*requires extended address*)
end (*NVPAS = 1*);
(*NVPAS = *) 2:
if IS_SIMPLE(VPA1) and
FITS_SHORT_INDEX(VPA2) then
SHORT_AND_REG (VPA2, VPA1)
else if IS_SIMPLE(VPA2) and
FITS_SHORT_INDEX(VPA1) then
SHORT_AND_REG (VPA1, VPA2)
else if (DTYPE<>TYPM) and (FPA=ZEROFPA) then
begin
(*be careful not to finish simplification
with integer arithmetic.*)
if VPA1.VSHIFT > 0 then
DEREF_AND_SHIFT (VPA1)
else if not IS_SIMPLE(VPA1) then
begin
VPA_OPERAND_NOSHIFT (OPND, VPA1);
DEREF (VPA1, OPND)
end
else if VPA2.VSHIFT > 0 then
DEREF_AND_SHIFT (VPA2)
else
begin
VPA_OPERAND_NOSHIFT (OPND, VPA2);
DEREF (VPA2, OPND)
end
end (*be careful...*)
else if VPA1.VSHIFT > 0 then
DEREF_AND_SHIFT (VPA1)
else if VPA2.VSHIFT > 0 then
DEREF_AND_SHIFT (VPA2)
else
ADD_VPAS;
end (*case NVPAS*);
end (*address arithmetic allowed*)
end (*with STK[STE]*);
if TR_SIMP then
begin
WRITELN (OUTPUT, ' Instruction(s) emitted:');
if OLDINSTREC = nil then OLDINSTREC := MAINCODE.FIRST;
while OLDINSTREC <> nil do
begin
UNKNOWN_LOC := 0;
DISASSEMBLE (UNKNOWN_LOC, OLDINSTREC);
OLDINSTREC := NEXT_INSTRUCTION(OLDINSTREC);
end;
OLDINSTREC := NEWINSTREC;
WRITELN (OUTPUT, ' Datum simplified');
PRINTDATUM (STE)
end;
end (*SIMPLIFY*);
(** DISASSEMBLE_CLASS: DISASSEMBLE PRINTLOC PRINTIWORD PRINTXWRD1 PRINTXWRD2 PRINTOPCODE PRINTOPERAND PRINTREG PRINTSHORTOP **)
(**)
procedure DISASSEMBLE(*(var CURPC : integer; IPTR : A_CODEREC)*);
(*This procedure disassembles and prints a single S1 instruction
starting at the word pointed to by IPTR, using CURPC as the
location of that instruction, and updates CURPC to indicate the
location of the next instruction.*)
var NXTPC : integer;
CURS1OPC : S1OPCODE;
ICW : S1WORD;
XPTR1, XPTR2, TPTR : A_CODEREC;
T : TWOBITS;
OWID : integer;
SLOC : CHAR10;
I, J : integer; (*LCW*)
(* Output format :
.........1.........2.........3.........4.........5.........6.........7
locationxx : instrwordxxx opcodemnemonicx <operands>
xopnd1wordxx (if any)
xopnd2wordxx (if any)
*)
procedure PRINTLOC;
var SLOC : CHAR10;
begin
CVOS_10(SLOC,CURPC);
WRITE(OUTPUT,SLOC,' : ')
end (*PRINTLOC*);
procedure PRINTIWORD;
var SWORD : CHAR12;
begin
CVOS_S1WORD_12(SWORD,ICW);
WRITE(OUTPUT,SWORD,' ')
end (*PRINTIWORD*);
procedure PRINTXWRD1;
var SWORD : CHAR12;
begin
if XPTR1 = nil then
(*no xword to print*)
else
begin
CVOS_S1WORD_12(SWORD,XPTR1↑.CODEWORD);
WRITELN(OUTPUT,' ',SWORD)
end
end (*PRINTXWRD1*);
procedure PRINTXWRD2;
var SWORD : CHAR12;
begin
if XPTR2 = nil then
(*no xword to print*)
else
begin
CVOS_S1WORD_12(SWORD,XPTR2↑.CODEWORD);
WRITELN(OUTPUT,' ',SWORD)
end
end (*PRINTXWRD2*);
procedure PRINTOPCODE;
begin
WRITE(OUTPUT,S1MNEM[CURS1OPC],' ')
end (*PRINTOPCODE*);
procedure PRINTOPERAND(var OWID : integer;
SHORTWORD : S1WORD;
XWORDPTR : A_CODEREC;
SHORTSTARTBIT : S1BITNUM);
(*Disassemble and print one S1 operand whose short part
starts at SHORTSTARTBIT in SHORTWORD and whose extended
part (if any) is in the CODEREC at XWORDPTR↑. Return
the number of characters printed in OWID.*)
var I, J, K, KSIGN, KWID : integer;
OPNDX : BIT;
OPNDREG : S1REGISTER;
OPNDF : MINSHORTOFFSET..MAXSHORTOFFSET;
XWORD : S1WORD;
SWORD : CHAR12;
procedure PRINTREG(R : S1REGISTER);
var RWID : integer;
begin
RWID := 3;
if R = S1RTA then WRITE(OUTPUT,'%RTA')
else if R = S1RTB then WRITE(OUTPUT,'%RTB')
else
begin
RWID := FLDW(R);
WRITE(OUTPUT,'%',R:RWID,'.'); (*LCW*)
end;
OWID := OWID + 1 + RWID + 1
end (*PRINTREG*);
procedure PRINTSHORTOP;
begin
if OPNDREG = 0 then PRINTREG(OPNDF)
else if OPNDREG = 1 then
begin (*short constant*)
KWID := FLDW(OPNDF);
WRITE(OUTPUT,'#',OPNDF:KWID,'.'); (*LCW*)
OWID := OWID + 1 + KWID + 1
end (*short constant*)
else if OPNDREG = 2 then if not (false) then
ASSERTFAIL('PRINTSHOR001')
else
begin (*short indexed*)
if not ((3 <= OPNDREG) and (OPNDREG <= LASTS1REG)) then
ASSERTFAIL('PRINTSHOR002');
K := OPNDF; (*LCW*)
KWID := FLDW(K);
WRITE(OUTPUT,K:KWID,'.('); (*LCW*)
OWID := OWID + KWID + 2;
PRINTREG(OPNDREG);
WRITE(OUTPUT,')');
OWID := OWID + 1
end (*short indexed*)
end (*PRINTSHORTOP*);
begin (*PRINTOPERAND*)
OPNDX := GETFIELD(SHORTWORD,SHORTSTARTBIT+OPNDX_START,
OPNDX_LEN);
OPNDREG := GETFIELD(SHORTWORD,SHORTSTARTBIT+OPNDREG_START,
OPNDREG_LEN);
OPNDF := GETSIGNEDFIELD(SHORTWORD,SHORTSTARTBIT+OPNDF_START,
OPNDF_LEN);
OWID := 0;
if OPNDX = 1 then
begin (*extended operand*)
if not (XWORDPTR <> nil) then ASSERTFAIL('PRINTOPER001');
XWORD := XWORDPTR↑.CODEWORD;
if (OPNDREG = 1) and (OPNDF <> 0) then
begin (*long constant*)
if not ((OPNDF>=1) and (OPNDF<=3)) then ASSERTFAIL('PRINTOPER002');
KSIGN := GETSIGNEDFIELD(XWORD,0,6);
WRITE(OUTPUT,'#',CHR(124)); (*LCW*)
OWID := OWID + 2; (*LCW*)
if ((KSIGN=0) or (KSIGN=-1)) and (OPNDF = 1) then
begin (*print in decimal*)
K := GETSIGNEDFIELD(XWORD,WORDBITS-(BITS_ON_COMP_MACH-1),
BITS_ON_COMP_MACH - 1);
if not (((KSIGN=0) and (K>=0))
or ((KSIGN=-1) and (K<0))) then
ASSERTFAIL('PRINTOPER003');
KWID := FLDW(K);
WRITE(OUTPUT,K:KWID,'.'); (*LCW*)
OWID := OWID + KWID + 1 (*LCW*)
end (*print in decimal*)
else
begin (*print in octal*)
CVOS_S1WORD_12(SWORD,XWORD);
J := 1;
while SWORD[J] = ' ' do J := J + 1;
(* WRITE(OUTPUT,'#'); *LCW*)
(* OWID := OWID +1; *LCW*)
for I := J to 12 do WRITE(OUTPUT,SWORD[I]);
OWID := OWID + (12+1) - J;
if OPNDF <> 1 then
begin
WRITE(OUTPUT,'F',OPNDF:1); (*???*)
OWID := OWID + 2
end;
end; (*print in octal*) (*LCW*)
WRITE(OUTPUT,CHR(124)); (*LCW*)
OWID := OWID + 1; (*LCW*)
end (*long constant*)
else
begin (*extended address*)
WRITE(OUTPUT,CHR(124)); (*LCW*)
OWID := OWID + 1; (*LCW*)
if GETFIELD(XWORD,XWI_START,XWI_LEN) = 1 then
begin (*indirect bit*)
WRITE(OUTPUT,'@'); (*LCW*)
OWID := OWID + 1
end (*indirect bit*);
if GETFIELD(XWORD,XWV_START,XWV_LEN) = 1 then
begin (*variable base*)
K := GETSIGNEDFIELD(XWORD,XWDISP_START,XWDISP_LEN);
KWID := FLDW(K);
WRITE(OUTPUT,K:KWID,'.('); (*LCW*)
OWID := OWID + KWID + 2;
PRINTREG(GETFIELD(XWORD,XWREG_START,XWREG_LEN));
WRITE(OUTPUT,')');
OWID := OWID + 1
end (*variable base*)
else
begin (*fixed base*)
K := GETFIELD(XWORD,XWADDR_START,XWADDR_LEN);
KWID := FLDW(K);
WRITE(OUTPUT,K:KWID,'.'); (*LCW*)
OWID := OWID + KWID + 1
end (*fixed base*);
WRITE(OUTPUT,CHR(124)); (*LCW*)
OWID := OWID + 1; (*LCW*)
if (OPNDREG=1) and (OPNDF=0) then
(*short-zero mode: no index to print*)
else
begin (*print index*)
WRITE(OUTPUT,'('); (*LCW*)
OWID := OWID + 1;
PRINTSHORTOP;
WRITE(OUTPUT,')'); (*LCW*)
OWID := OWID + 1; (*LCW*)
K := GETFIELD(XWORD,XWS_START,XWS_LEN);
if K <> 0 then
begin (*print shift*)
(* K := TWOEXP[K]; *LCW*)
KWID := FLDW(K);
WRITE(OUTPUT,'↑',K:KWID); (*LCW*)
OWID := OWID + 1 + KWID
end (*print shift*);
(* WRITE(OUTPUT,']'); *LCW*)
(* OWID := OWID + 1 *LCW*)
end (*print index*)
end (*extended address*)
end (*extended operand*)
else
begin (*short operand*)
if not (XWORDPTR = nil) then ASSERTFAIL('PRINTOPER004');
PRINTSHORTOP
end (*short operand*)
end (*PRINTOPERAND*);
begin (*DISASSEMBLE*)
CURS1OPC := GETS1OPCODE(IPTR);
XPTR1 := nil; XPTR2 := nil;
ICW := IPTR↑.CODEWORD;
NXTPC := CURPC;
case OPFORMAT[CURS1OPC] of
VFAKEOP:
(*ignore it*);
VTOP, VXOP, VSOP:
begin
PRINTLOC;
PRINTIWORD;
TPTR := IPTR↑.NEXTPTR;
NXTPC := NXTPC + WORDUNITS;
if GETFIELD(ICW,OPND2X_START,OPND2X_LEN) = 1 then
begin
NXTPC := NXTPC + WORDUNITS;
XPTR2 := TPTR;
TPTR := TPTR↑.NEXTPTR
end;
if GETFIELD(ICW,OPND1X_START,OPND1X_LEN) = 1 then
begin
NXTPC := NXTPC + WORDUNITS;
XPTR1 := TPTR;
TPTR := TPTR↑.NEXTPTR
end;
PRINTOPCODE;
if OPFORMAT[CURS1OPC] = VTOP then
begin (*VTOP*)
T := GETFIELD(ICW,T_START,T_LEN);
if T = 1 then
begin (* OP1 = RTA, OP2 *)
PRINTOPERAND(OWID,ICW,XPTR1,OPND1_START);
WRITE(OUTPUT,' , %RTA, '); (*LCW*)
PRINTOPERAND(OWID,ICW,XPTR2,OPND2_START)
end (* OP1 = RTA, OP2 *)
else
begin
if T = 2 then WRITE(OUTPUT,'%RTA , ') (*LCW*)
else if T = 3 then WRITE(OUTPUT,'%RTB , ') (*LCW*)
(*else T = 0*);
PRINTOPERAND(OWID,ICW,XPTR1,OPND1_START);
WRITE(OUTPUT,', ');
PRINTOPERAND(OWID,ICW,XPTR2,OPND2_START)
end
end (*VTOP*)
else
begin (*VXOP, VSOP*)
PRINTOPERAND(OWID,ICW,XPTR1,OPND1_START);
WRITE(OUTPUT,', ');
PRINTOPERAND(OWID,ICW,XPTR2,OPND2_START);
if OPFORMAT[CURS1OPC] = VSOP then
begin (*VSOP*)
CVOS_10(SLOC,CURPC + WORDUNITS*GETSIGNEDFIELD
(ICW,SKP_START,SKP_LEN));
(* WRITE(OUTPUT,' :',SLOC) *LCW*)
WRITE(OUTPUT,' , '); (*LCW*)
J := 1; (*LCW*)
while SLOC[J] = ' ' do J := J+1; (*LCW*)
for I := J to 10 do WRITE(OUTPUT,SLOC[I]); (*LCW*)
end (*VSOP*)
end (*VXOP, VSOP*);
WRITELN(OUTPUT);
PRINTXWRD2;
PRINTXWRD1;
end (*VTOP, VXOP, VSOP*);
VJOP:
begin
PRINTLOC;
PRINTIWORD;
TPTR := IPTR↑.NEXTPTR;
NXTPC := NXTPC + WORDUNITS;
if ((JUMPS_CONCRETIZED
and (GETFIELD(ICW,PR_START,PR_LEN) = 0))
or (not JUMPS_CONCRETIZED))
and (GETFIELD(ICW,OPND2X_START,OPND2X_LEN) = 1) then
begin
NXTPC := NXTPC + WORDUNITS;
XPTR2 := TPTR;
TPTR := TPTR↑.NEXTPTR
end;
if GETFIELD(ICW,OPND1X_START,OPND1X_LEN) = 1 then
begin
NXTPC := NXTPC + WORDUNITS;
XPTR1 := TPTR;
TPTR := TPTR↑.NEXTPTR
end;
PRINTOPCODE;
PRINTOPERAND(OWID,ICW,XPTR1,OPND1_START);
WRITE(OUTPUT,' ,'); (*LCW*)
if JUMPS_CONCRETIZED and
(GETFIELD(ICW,PR_START,PR_LEN) = 1) then
begin (*PC relative*)
CVOS_10(SLOC,CURPC + WORDUNITS*GETSIGNEDFIELD
(ICW,J_START,J_LEN));
(* WRITE(OUTPUT,SLOC) *LCW*)
WRITE(OUTPUT,' '); (*LCW*)
J := 1; (*LCW*)
while SLOC[J] = ' ' do J := J+1; (*LCW*)
for I := J to 10 do WRITE(OUTPUT,SLOC[I]); (*LCW*)
end (*PC relative*)
else
begin (*print OPND2*)
WRITE(OUTPUT,' ');
PRINTOPERAND(OWID,ICW,XPTR2,OPND2_START)
end (*print OPND2*);
WRITELN(OUTPUT);
PRINTXWRD2;
PRINTXWRD1;
end (*VJOP*)
end (*case*);
CURPC := NXTPC
end (*DISASSEMBLE*);
(** OBJECT_MODULE_SEGMENT_CLASS: CODE_CONCRETIZER INSTR_WORDS **)
(**)
procedure CODE_CONCRETIZER;
(*Concretize the MAINCODE code in three passes. On pass 1, insert
fake S1LOC instructions at each jump or skip destination. On
pass 2, compute a final PC value as code is passed, filling the
current PC value into each S1LOC instruction. Also, fix up all
PC relative extended operands by subtracting the PC value from
their displacements. On pass 3, fix up all jump and skip
instructions by inserting final PC relative references.*)
const MAXS1LOC = 16777215 (*2**24-1*);
S1LOCUNDEF = MAXS1LOC;
var
IPTR, NXTIPTR, JPTR, TPTR, LASTPTR : A_CODEREC;
NXTPC, TPC, PASS2_MAXPC : 0..MAXS1LOC;
CURS1OPC : S1OPCODE;
ICW : S1WORD;
BIGJUMPS, PASS2_NEEDED : boolean;
function INSTR_WORDS(INSTLOC : A_CODEREC; INSTPC : integer) : integer;(*PTZ*)
var ICW : S1WORD;
TWDS, JMPOFF : integer;
S1OPC : S1OPCODE;
TPC : 0..MAXS1LOC;
JPTR : A_CODEREC;
begin
ICW := INSTLOC↑.CODEWORD;
S1OPC := GETS1OPCODE(INSTLOC);
if OPFORMAT[S1OPC] = VFAKEOP then
TWDS := 0
else
begin (*not VFAKEOP*)
TWDS := 1;
if GETFIELD(ICW,OPND2X_START,OPND2X_LEN) = 1 then
(*extended OPND2*)
TWDS := TWDS + 1;
if GETFIELD(ICW,OPND1X_START,OPND1X_LEN) = 1 then
(*extended OPND1*)
TWDS := TWDS + 1;
if OPFORMAT[S1OPC] = VJOP then
begin (*any VJOP*)
JPTR := JUMPSKIPDEST(INSTLOC);
if GETFIELD(ICW,PR_START,PR_LEN) = 1 then
(*force two-word jump: this is in a jump table.
The instruction should be a JMPA so OPND1 won't
be extended. 2-word jump ASSERTed in CONC_PASS3*)
TWDS := 2
else if JPTR <> nil then
begin (*normal jump*)
if not (GETS1OPCODE(JPTR) = XS1LOC) then
ASSERTFAIL('CODE_CONC001');
TPC := GETFIELD(JPTR↑.CODEWORD,FAKEOPND_START,FAKEOPND_LEN);
if (TPC <> S1LOCUNDEF) and (TPC < INSTPC) then
begin (*backward jump: can't rely on previous
estimate because no way to communicate decision
to CONC_PASS3 for inserting NOP purposes*)
if GETFIELD(ICW,OPND2X_START,OPND2X_LEN) = 0 then
begin
JMPOFF := (TPC - INSTPC) div WORDUNITS;
if JMPOFF < MINJPROFFSET then
(*if not already extended OPND2 and
won't fit PC-relative, assume
extended OPND2*)
TWDS := TWDS + 1
end
end (*backward jump*)
else
begin (*forward jump*)
if (GETFIELD(ICW,OPND2X_START,OPND2X_LEN) = 0)
and BIGJUMPS then
(*if not already extended OPND2, assume
extended OPND2 (worst case)*)
TWDS := TWDS + 1
end (*forward jump*)
end (*normal jump*)
end (*any VJOP*)
end (*not VFAKEOP*);
INSTR_WORDS := TWDS
end (*INSTR_WORDS*);
(** OBJECT_MODULE_SEGMENT_CLASS: CONC_PASS1 INSERT_S1LOC JMPX_TO_JMPA_OPT **)
(**)
procedure CONC_PASS1; (*PBK*)
(* first pass over the code inserts S1LOC fake instructions
at the destination of each skip or jump.
peephole optimization of jumps to jumps is done during
this pass. *)
procedure INSERT_S1LOC (BEFORE : A_CODEREC); (*PBK*)
(* This inserts an S1LOC fake instruction before the CODEREC
pointed to by BEFORE. To preserve pointers this is done
by moving the CODEREC in BEFORE to a new CODEREC and replacing
it with the S1LOC. *)
var
AFTER : A_CODEREC;
begin
if BEFORE <> nil then
(* if GETS1OPCODE(BEFORE) <> S1LOC then PBK*)
begin
NEWCODEREC(AFTER);
AFTER↑ := BEFORE↑;
BEFORE↑.NEXTPTR := AFTER;
BEFORE↑.CODEWORD := ZEROS1WORD;
PUTFIELD(BEFORE↑.CODEWORD,
OPCODE_START,OPCODE_LEN,
HARDOPCODE[XS1LOC]);
PUTFIELD(BEFORE↑.CODEWORD,
FAKEOPND_START,FAKEOPND_LEN,
S1LOCUNDEF);
MAINCODE.NWORDS := MAINCODE.NWORDS + 1;
end (* if BEFORE <> nil then *);
end (* procedure INSERT_S1LOC *);
procedure JMPX_TO_JMPA_OPT ( INSTLOC : A_CODEREC ); (*PBK*)
(* This procedure takes the jump instruction at INSTLOC
and follows the chain (if any) of its destination
through any JMPAs to make the destination the final
destination of the chain of JMPAs (if any).
This saves just a little bit of time, but it makes
the code more esthetically pleasing [huh?] *)
var
JMP_TO_JMPA : boolean;
DESTPTR, DESTINSTPTR, INSTDESTPTR : A_CODEREC;
begin
if GETFIELD(INSTLOC↑.CODEWORD,OPND2X_START,OPND2X_LEN) = 0 then
begin
DESTPTR := JUMPSKIPDEST(INSTLOC);
repeat (* until not JMP_TO_JMPA *)
JMP_TO_JMPA := false;
if DESTPTR <> nil then
begin
DESTINSTPTR := AFTER_FAKEOPS(DESTPTR);
if DESTINSTPTR <> nil then
begin
if GETS1OPCODE(DESTINSTPTR) = XJMPA then
begin
DESTPTR := JUMPSKIPDEST(DESTINSTPTR);
JMP_TO_JMPA := true;
J_TO_J_CNT := J_TO_J_CNT + 1;
end
(* if GETS1OPCODE(DESTINSTPTR) = XJMPA then *)
end (* if DESTINSTPTR <> nil then *)
end (* if DESTPTR <> nil then *)
until not JMP_TO_JMPA;
(* fix jump or skip destination of start of jump chain *)
INSTDESTPTR := AFTER_LAST_XWORD(INSTLOC);
INSTDESTPTR↑.CODEPTR := DESTPTR;
end;
(* else
this JMPX has an extended destination word and hence is
too complicated to chain - specifically it may be an
indexed jump into a jump table (in this case the jumpdest
ptr points to the first jump in the table - DON'T chain
this since it won't in general actually execute through
the first jump) *)
end (* JMPX_TO_JMPA_OPT *);
begin (* CONC_PASS1 *)
IPTR := MAINCODE.FIRST;
while IPTR <> nil do
begin
NXTIPTR := NEXT_INSTRUCTION(IPTR);
CURS1OPC := GETS1OPCODE(IPTR);
if OPFORMAT[CURS1OPC] in [VJOP,VSOP] then
begin
if OPFORMAT[CURS1OPC] = VJOP then
(* attempt to optimize jumps to JMPAs.
don't try to do skips to JMPAs, since
that would almost certainly make the skip
not reach, and we can't fix that up now. *)
JMPX_TO_JMPA_OPT(IPTR);
INSERT_S1LOC(JUMPSKIPDEST(IPTR));
end (* if OPFORMAT[CURS1OPC] in [VJOP,VSOP] then *);
IPTR := NXTIPTR;
end (*while IPTR <> nil do*);
if MAINCODE.LAST <> nil then
while MAINCODE.LAST↑.NEXTPTR <> nil do
MAINCODE.LAST := MAINCODE.LAST↑.NEXTPTR;
end (*CONC_PASS1*);
(** OBJECT_MODULE_SEGMENT_CLASS: PEEPHOLE_OPTIMIZER DELETE_INSTR SKIP_JMPA_OPT COLLAPSE_MOV_OPT **)
(**)
procedure PEEPHOLE_OPTIMIZER (var CHANGES : boolean); (*PTZ*)
type LVXWDS =
(LEAVENOXWDS, LEAVEOPND1XWD, LEAVEOPND2XWD, LEAVEBOTHXWDS);
var PREV_IPTR : A_CODEREC;
WDS_REMOVED_THIS_PASS, PC_ADJ : integer;
procedure DELETE_INSTR
(PREVPTR, DELPTR : A_CODEREC; LEAVE_XWDS : LVXWDS);
(*PREVPTR points to the 1st CODEREC of the instruction preceding
the instruction to be deleted.
DELPTR points to the 1st CODEREC of the instruction to be deleted.
LEAVE_XWDS indicates which, if any, of the extended words of the
instruction are to be retained.
The calling routine must take care of any PC estimate adjustments
which may be required*)
var TPTR : A_CODEREC;
DELS1OPFORMAT : S1OPFORMAT;
begin
(*first find the CODEREC immediately preceding DELPTR.
Don't rely on the Xword information in the PREVPTR instruction,
because if some Xwords are to be retained from the deleted
instruction it may not currently be correct*)
TPTR := PREVPTR;
while TPTR <> DELPTR do
begin
PREVPTR := TPTR;
TPTR := TPTR↑.NEXTPTR
end;
DELS1OPFORMAT := OPFORMAT[GETS1OPCODE(DELPTR)];
TPTR := DELPTR↑.NEXTPTR;
MAINCODE.NWORDS := MAINCODE.NWORDS - 1;
if DELS1OPFORMAT <> VFAKEOP then
begin
WDS_REMOVED_THIS_PASS := WDS_REMOVED_THIS_PASS + 1;
if (LEAVE_XWDS<>LEAVEOPND2XWD) and (LEAVE_XWDS<>LEAVEBOTHXWDS)
and (GETFIELD(DELPTR↑.CODEWORD,OPND2X_START,OPND2X_LEN) = 1)
then
begin
TPTR := TPTR↑.NEXTPTR;
MAINCODE.NWORDS := MAINCODE.NWORDS - 1;
WDS_REMOVED_THIS_PASS := WDS_REMOVED_THIS_PASS + 1
end;
if (LEAVE_XWDS<>LEAVEOPND1XWD) and (LEAVE_XWDS<>LEAVEBOTHXWDS)
and (GETFIELD(DELPTR↑.CODEWORD,OPND1X_START,OPND1X_LEN) = 1)
then
begin
TPTR := TPTR↑.NEXTPTR;
MAINCODE.NWORDS := MAINCODE.NWORDS - 1;
WDS_REMOVED_THIS_PASS := WDS_REMOVED_THIS_PASS + 1
end;
if (DELS1OPFORMAT = VSOP) or (DELS1OPFORMAT = VJOP) then
begin
TPTR := TPTR↑.NEXTPTR;
MAINCODE.NWORDS := MAINCODE.NWORDS - 1
end
end (*if DELS1OPFORMAT <> VFAKEOP then*);
PREVPTR↑.NEXTPTR := TPTR
end (*DELETE_INSTR*);
procedure SKIP_JMPA_OPT (SKIPPTR : A_CODEREC; SKIPPC : integer);
var JMPAPTR, JMPADESTPTR, TPTR, S1LOCPTR : A_CODEREC;
JPC : 0..MAXS1LOC;
SKIP_WORDS, JMPA_WORDS : 1..3; (*create a TYPE*)
JMPOFF : integer;
begin
JMPAPTR := NEXT_INSTRUCTION(SKIPPTR);
if (GETS1OPCODE(JMPAPTR) = XJMPA)
and (GETFIELD(JMPAPTR↑.CODEWORD,PR_START,PR_LEN) <> 1) then
begin (*not in jump table*)
SKIP_WORDS := INSTR_WORDS(SKIPPTR,SKIPPC);
JMPA_WORDS := INSTR_WORDS(JMPAPTR,SKIPPC +
SKIP_WORDS*WORDUNITS);
JMPADESTPTR := JUMPSKIPDEST(JMPAPTR);
if not (GETS1OPCODE(JMPADESTPTR) = XS1LOC) then
ASSERTFAIL('SKIP_JMPA001');
JPC := GETFIELD
(JMPADESTPTR↑.CODEWORD,FAKEOPND_START,FAKEOPND_LEN);
if JPC <> S1LOCUNDEF then
begin (*backward skip or ≥ 2nd pass*)
JMPOFF := (JPC - SKIPPC) div WORDUNITS;
if JMPOFF > 0 then
JMPOFF := JMPOFF - (JMPA_WORDS + WDS_REMOVED_THIS_PASS)
end
else
begin (*forward skip: 1st pass only*)
JMPOFF := INSTR_WORDS(SKIPPTR,SKIPPC);
TPTR := NEXT_INSTRUCTION(JMPAPTR);
while (JMPOFF <= MAXSKPOFFSET) and (TPTR <> JMPADESTPTR)
and (TPTR <> nil) do
begin
JMPOFF := JMPOFF
+ INSTR_WORDS(TPTR,SKIPPC + JMPOFF*WORDUNITS);
TPTR := NEXT_INSTRUCTION(TPTR)
end;
end;
if (MINSKPOFFSET <= JMPOFF)
and (JMPOFF <= MAXSKPOFFSET) then
begin
(* SKP.COND.X Y,Z,L1 -> SKP.OPPCOND.X Y,Z,L2
JMPA L2
L1: S1LOC
(MINSKPOFFSET <= L2-SKP <= MAXSKPOFFSET)
There is 1 S1LOC for each time a place is used as a
destination, so we can optimize across the boundary
when the last one goes away *)
JMPAS_REMOVED_FROM_SKIPS := JMPAS_REMOVED_FROM_SKIPS + 1;
INVERT_SKIP(SKIPPTR);
S1LOCPTR := NEXT_INSTRUCTION(JMPAPTR);
if not (GETS1OPCODE(S1LOCPTR) = XS1LOC) then
ASSERTFAIL('TRY_SKIP 001');
TPTR := AFTER_LAST_XWORD(SKIPPTR);
TPTR↑.CODEPTR := JMPADESTPTR;
DELETE_INSTR(SKIPPTR,JMPAPTR,LEAVENOXWDS);
DELETE_INSTR(SKIPPTR,S1LOCPTR,LEAVENOXWDS)
end
end
end (*SKIP_JMPA_OPT*);
procedure COLLAPSE_MOV_OPT (PREVPTR, MOVPTR : A_CODEREC;
MOV_PRECISION : S1PRECISION);
var MOV_OPND1, MOV_OPND2, T : integer;
PREVS1OPC : S1OPCODE;
TPTR : A_CODEREC;
FOUND, STILL_LOOKING : boolean;
begin
MOV_OPND2 := S1OPND_TEMPLOC(MOVPTR,OPND2_START);
PREVS1OPC := GETS1OPCODE(PREVPTR);
if (MOV_OPND2 >= 0) and (DEST_PRECISION[PREVS1OPC] = MOV_PRECISION)
and COLLAPSIBLE_OP[PREVS1OPC] then
begin
TPTR := NEXT_INSTRUCTION(MOVPTR);
FOUND := false;
STILL_LOOKING := TPTR <> nil;
while STILL_LOOKING and not FOUND do
begin
if GETS1OPCODE(TPTR) <> XFREEREG then
STILL_LOOKING := false
else (*GETS1OPCODE(TPTR) = XFREEREG*)
if GETFIELD(TPTR↑.CODEWORD,FAKEOPND_START,FAKEOPND_LEN)
= MOV_OPND2 then
FOUND := true
else
begin
TPTR := NEXT_INSTRUCTION(TPTR);
STILL_LOOKING := TPTR <> nil
end
end (*while*);
if FOUND then
(*We now know that the source of the MOV.X.X is
no longer going to be used, and that the instruction
preceding the MOV.X.X is a collapsible one.
Now look for certain patterns in the collapsible inst*)
begin
MOV_OPND1 := GETFIELD
(MOVPTR↑.CODEWORD,OPND1_START,OPND1_LEN);
if OPFORMAT[PREVS1OPC] = VXOP then
begin
(* collapsibleXOP.X.W TREG,Y-> collapsibleXOP.X.W Z,Y
MOV.X.X Z,TREG
REGFREED TREG REGFREED TREG *)
if S1OPND_TEMPLOC(PREVPTR,OPND1_START) = MOV_OPND2 then
begin
MOVS_COLLAPSED := MOVS_COLLAPSED + 1;
PUTFIELD(PREVPTR↑.CODEWORD,OPND1_START,
OPND1_LEN,MOV_OPND1);
DELETE_INSTR(PREVPTR,MOVPTR,LEAVEOPND1XWD)
end
end (*XOP*)
else
begin
if not (OPFORMAT[PREVS1OPC] = VTOP) then
ASSERTFAIL('COLLAPSE 001');
T := GETFIELD(PREVPTR↑.CODEWORD,T_START,T_LEN);
if (T = 1)
and (S1OPND_TEMPLOC
(PREVPTR,OPND1_START) = MOV_OPND2) then
begin
(* TOP.X TREG,RTA,Y -> reverseTOP.X Y,RTA
MOV.X.X Y,TREG
REGFREED TREG REGFREED TREG *)
MOVS_COLLAPSED := MOVS_COLLAPSED + 1;
if S1OPNDS_EQUAL(PREVPTR,OPND2_START,
MOVPTR,OPND1_START) then
begin
if not (REVERSE_OP[PREVS1OPC] <> XILLEGAL) then
ASSERTFAIL('COLLAPSE 002');
PREVPTR↑.CODEWORD := ZEROS1WORD;
PUTFIELD(PREVPTR↑.CODEWORD,OPCODE_START,
OPCODE_LEN,HARDOPCODE[REVERSE_OP[PREVS1OPC]]);
PUTFIELD(PREVPTR↑.CODEWORD,OPND1_START,
OPND1_LEN,MOV_OPND1);
PUTFIELD(PREVPTR↑.CODEWORD,OPND2F_START,
OPND2F_LEN,S1RTA);
DELETE_INSTR(PREVPTR,MOVPTR,LEAVENOXWDS)
end
else
begin
(* TOP.X TREG,RTA,Y -> TOP.X Z,RTA,Y
MOV.X.X Z,TREG
REGFREED TREG REGFREED TREG *)
PUTFIELD(PREVPTR↑.CODEWORD,OPND1_START,
OPND1_LEN,MOV_OPND1);
DELETE_INSTR(PREVPTR,MOVPTR,LEAVEOPND1XWD)
end
end (*(T=1) and (PREV OPND1=MOV_OPND2)*)
else if ((T=2) and (MOV_OPND2=S1RTA))
or ((T=3) and (MOV_OPND2=S1RTB)) then
begin
if S1OPNDS_EQUAL(PREVPTR,OPND1_START,
MOVPTR,OPND1_START) then
begin
(* TOP.X RTAorRTB,Y,Z -> TOP.X Y,Z
MOV.X.X Y,RTAorRTB
REGFREED RTAorRTB REGFREED RTAorRTB *)
MOVS_COLLAPSED := MOVS_COLLAPSED + 1;
PUTFIELD(PREVPTR↑.CODEWORD,T_START,T_LEN,0);
DELETE_INSTR(PREVPTR,MOVPTR,LEAVENOXWDS)
end
end
end (*TOP*)
end (*if FOUND then*)
end
end (*COLLAPSE_MOV_OPT*);
begin (*PEEPHOLE_OPTIMIZER*)
(* The first pass of the peephole optimizer removes or simplifies
any instructions that it can *)
WDS_REMOVED_THIS_PASS := 0;
IPTR := MAINCODE.FIRST;
PREV_IPTR := nil;
CURPC := SEG_EP_RELPC;
while IPTR <> nil do
begin
CURS1OPC := GETS1OPCODE(IPTR);
if (OPFORMAT[CURS1OPC] = VXOP) and (PREV_IPTR <> nil) then
begin
(*EJG Buggy optimizations get commented out...
if CURS1OPC = XMOV_S_S then
COLLAPSE_MOV_OPT(PREV_IPTR,IPTR,S1S)
else if CURS1OPC = XMOV_Q_Q then
COLLAPSE_MOV_OPT(PREV_IPTR,IPTR,S1Q)
else if CURS1OPC = XMOV_D_D then
COLLAPSE_MOV_OPT(PREV_IPTR,IPTR,S1D)
else if CURS1OPC = XMOV_H_H then
COLLAPSE_MOV_OPT(PREV_IPTR,IPTR,S1H)
...end of buggy optimizations EJG 14NOV78*)
end;
if (OPFORMAT[CURS1OPC] <> VFAKEOP) or (CURS1OPC = XS1LOC) then
PREV_IPTR := IPTR;
IPTR := NEXT_INSTRUCTION(IPTR);
end (*while IPTR <> nil do*);
INSTR_WDS_REMOVED := INSTR_WDS_REMOVED + WDS_REMOVED_THIS_PASS;
(* The rest of the peephole optimizer - at most MAXPEEPASSES -
does a straightforward collapse of skips around JMPAs that
are short enough to be a skip alone. A small amount of testing
shows that the first pass gets about 90 percent of the cases
and the second pass gets a few percent more, etc.
We don't combine this optimization with the previous group
because keeping track of the PC while deleting instructions
and pieces of instructions is difficult *)
PASS2_MAXPC := MAINCODE.NWORDS;
(*this will work as long as MAINCODE.NWORDS is an upper
bound on the number of words of instructions emitted*)
CHANGES := true;
PEEP_PASSES_REQRD := 0;
while CHANGES and (PEEP_PASSES_REQRD < MAXPEEP_PASSES) do
begin
WDS_REMOVED_THIS_PASS := 0;
IPTR := MAINCODE.FIRST;
CURPC := SEG_EP_RELPC;
BIGJUMPS := (PASS2_MAXPC div WORDUNITS) > MAXJPROFFSET;
while IPTR <> nil do
begin
CURS1OPC := GETS1OPCODE(IPTR);
if OPFORMAT[CURS1OPC] = VFAKEOP then
begin
if CURS1OPC = XS1LOC then
PUTFIELD
(IPTR↑.CODEWORD,FAKEOPND_START,FAKEOPND_LEN,CURPC)
end
else
begin
if OPFORMAT[CURS1OPC] = VSOP then
SKIP_JMPA_OPT(IPTR,CURPC)
end;
CURPC := CURPC + INSTR_WORDS(IPTR,CURPC)*WORDUNITS;
IPTR := NEXT_INSTRUCTION(IPTR);
end (*while IPTR <> nil do*);
CHANGES := WDS_REMOVED_THIS_PASS <> 0;
PASS2_MAXPC := CURPC;
INSTR_WDS_REMOVED := INSTR_WDS_REMOVED + WDS_REMOVED_THIS_PASS;
PEEP_PASSES_REQRD := PEEP_PASSES_REQRD + 1
end;
end (*PEEPHOLE_OPTIMIZER*);
(** OBJECT_MODULE_SEGMENT_CLASS: CONC_PASS2 **)
(**)
procedure CONC_PASS2; (*PTZ*)
begin
IPTR := MAINCODE.FIRST;
CURPC := SEG_EP_RELPC;
BIGJUMPS := (PASS2_MAXPC div WORDUNITS) > MAXJPROFFSET;
while IPTR <> nil do
begin
CURS1OPC := GETS1OPCODE(IPTR);
if OPFORMAT[CURS1OPC] = VFAKEOP then
begin
if CURS1OPC = XS1LOC then
PUTFIELD(IPTR↑.CODEWORD,FAKEOPND_START,FAKEOPND_LEN,CURPC)
end;
CURPC := CURPC + INSTR_WORDS(IPTR,CURPC)*WORDUNITS;
IPTR := NEXT_INSTRUCTION(IPTR)
end (*while IPTR <> nil do*);
PASS2_MAXPC := CURPC
end (*CONC_PASS2*);
(** OBJECT_MODULE_SEGMENT_CLASS: CONC_PASS3 PASS3XWORDFIX INSERT_NOP **)
(**)
procedure CONC_PASS3; (*PTZ*)
var SKPOFF : MINSKPOFFSET..MAXSKPOFFSET;
JMPOFF : integer;
TOPND : OPERAND;
FORCE2 : boolean;
procedure PASS3PCRELFIX(SHORTWORD : S1WORD; (*EJG*)
var XWORD : S1WORD;
SHORTSTARTBIT : S1BITNUM);
(*Examine the extended non-constant S1 operand in SHORTWORD
and XWORD whose short part starts at SHORTSTARTBIT in
SHORTWORD. If it is PC relative, fix it up by subtracting
the current PC value from the displacement.*)
var VBIT : BIT;
begin
if not (
GETFIELD
(SHORTWORD,SHORTSTARTBIT+OPNDX_START,OPNDX_LEN) = 1) then
ASSERTFAIL('PASS3PCRE001');
VBIT := GETFIELD(XWORD,XWV_START,XWV_LEN);
if ((GETFIELD(SHORTWORD,SHORTSTARTBIT+OPNDREG_START,OPNDREG_LEN)=0)
and
(GETFIELD(SHORTWORD,SHORTSTARTBIT+OPNDF_START,OPNDF_LEN)=S1RPC))
or ((VBIT = 1)
and
(GETFIELD(XWORD,XWREG_START,XWREG_LEN) = S1RPC))
then
if VBIT = 1 then
PUTFIELD(XWORD,XWDISP_START,XWDISP_LEN,
GETSIGNEDFIELD(XWORD,XWDISP_START,XWDISP_LEN)
- CURPC)
else
PUTFIELD(XWORD,XWADDR_START,XWADDR_LEN,
GETSIGNEDFIELD(XWORD,XWADDR_START,XWADDR_LEN)
- CURPC);
end (*PASS3PCRELFIX*);
procedure INSERT_NOP;
(*Insert a single word no-op in the code immediately following
the word at LASTPTR, updating NXTPC (and MAINCODE.NWORDS).*)
var OPND : OPERAND;
begin
INSERTXOP(LASTPTR,XNOP,UNUSED_OP,UNUSED_OP); (*LCW*)
NXTPC := NXTPC + WORDUNITS
end (*INSERT_NOP*);
begin (*CONC_PASS3*)
IPTR := MAINCODE.FIRST;
CURPC := SEG_EP_RELPC;
BIGJUMPS := ((PASS2_MAXPC div WORDUNITS) > MAXJPROFFSET);
while IPTR <> nil do
begin
NXTIPTR := NEXT_INSTRUCTION(IPTR);
NXTPC := CURPC;
CURS1OPC := GETS1OPCODE(IPTR);
if OPFORMAT[CURS1OPC] = VFAKEOP then
begin
if CURS1OPC = XS1LOC then
if not (GETFIELD(IPTR↑.CODEWORD,
FAKEOPND_START,FAKEOPND_LEN) = CURPC) then
ASSERTFAIL('CODE_CONC002')
end
else (*not VFAKEOP*)
begin
ICW := IPTR↑.CODEWORD;
NXTPC := NXTPC + WORDUNITS;
TPTR := IPTR↑.NEXTPTR;
if GETFIELD(ICW,OPND2X_START,OPND2X_LEN) = 1 then
begin (*extended OPND2*)
NXTPC := NXTPC + WORDUNITS;
if not (*PTZ*)
((GETFIELD(ICW,OPND2F_START,OPND2F_LEN) > 0) and (*PTZ*)
(GETFIELD(ICW,OPND2REG_START,OPND2REG_LEN) = 1)) (*PTZ*)
then (*PTZ*)
PASS3PCRELFIX(ICW,TPTR↑.CODEWORD,OPND2_START); (*EJG*)
TPTR := TPTR↑.NEXTPTR
end;
if GETFIELD(ICW,OPND1X_START,OPND1X_LEN) = 1 then
begin (*extended OPND1*)
NXTPC := NXTPC + WORDUNITS;
if not (*PTZ*)
((GETFIELD(ICW,OPND1F_START,OPND1F_LEN) > 0) and (*PTZ*)
(GETFIELD(ICW,OPND1REG_START,OPND1REG_LEN) = 1)) (*PTZ*)
then (*PTZ*)
PASS3PCRELFIX(ICW,TPTR↑.CODEWORD,OPND1_START); (*EJG*)
TPTR := TPTR↑.NEXTPTR
end;
if OPFORMAT[CURS1OPC] = VSOP then
begin (*any VSOP*)
JPTR := TPTR↑.CODEPTR;
if JPTR <> nil then
begin
if not (GETS1OPCODE(JPTR) = XS1LOC) then
ASSERTFAIL('CODE_CONC003');
TPC := GETFIELD(JPTR↑.CODEWORD,
FAKEOPND_START,FAKEOPND_LEN);
if not (TPC <> S1LOCUNDEF) then
ASSERTFAIL('CODE_CONC004');
SKPOFF := (TPC-CURPC) div WORDUNITS;
if not ((MINSKPOFFSET<=SKPOFF)
and (SKPOFF<=MAXSKPOFFSET)) then
ASSERTFAIL('CODE_CONC005');
PUTFIELD(IPTR↑.CODEWORD,SKP_START,SKP_LEN,SKPOFF)
end
end (*any VSOP*)
else if OPFORMAT[CURS1OPC] = VJOP then
begin (*any VJOP*)
JPTR := TPTR↑.CODEPTR;
LASTPTR := TPTR;
FORCE2 := (GETFIELD(ICW,PR_START,PR_LEN) = 1)
(*force two-word jump*);
if JPTR = nil then
begin (*no JUMPDEST: leave alone except FORCE2*)
TPC := CURPC; (*bookkeeping: not forward*) (*PTZ*)
PUTFIELD (IPTR↑.CODEWORD, PR_START, PR_LEN, 0);
end (*no JUMPDEST*)
else
begin
if not (GETS1OPCODE(JPTR) = XS1LOC) then
ASSERTFAIL('CODE_CONC006');
TPC := GETFIELD(JPTR↑.CODEWORD,
FAKEOPND_START,FAKEOPND_LEN);
if not (TPC <> S1LOCUNDEF) then
ASSERTFAIL('CODE_CONC007');
JMPOFF := (TPC-CURPC) div WORDUNITS;
if (MINJPROFFSET<=JMPOFF)and(JMPOFF<=MAXJPROFFSET)
and(GETFIELD(ICW,OPND2X_START,OPND2X_LEN)=0) then
begin (*PR-style jump*)
PUTFIELD(IPTR↑.CODEWORD,PR_START,PR_LEN,1);
PUTFIELD(IPTR↑.CODEWORD,J_START,J_LEN,JMPOFF)
end (*PR-style jump*)
else
begin (*non PR-style jump*)
PUTFIELD(IPTR↑.CODEWORD,PR_START,PR_LEN,0);
if GETFIELD(ICW,OPND2X_START,OPND2X_LEN)=0 then
begin (*build an extended OPND2*)
if not (BIGJUMPS)
then ASSERTFAIL('CODE_CONC010');
NXTPC := NXTPC + WORDUNITS;
NEWCODEREC(TPTR);
TPTR↑.NEXTPTR := IPTR↑.NEXTPTR;
IPTR↑.NEXTPTR := TPTR;
TOPND := ZERO_OP;
TOPND.X := 1; TOPND.F := 0; TOPND.REG := 1;
TOPND.XW.V := 1; TOPND.XW.REG := S1RPC;
TOPND.XW.DISP := -CURPC;
BUILD_CW_OPERAND(IPTR↑.CODEWORD,
TPTR,TOPND,OPND2_START);
MAINCODE.NWORDS := MAINCODE.NWORDS + 1
end (*build an extended OPND2*);
TPTR := IPTR↑.NEXTPTR;
(*get pointer to extended OPND2*)
PUTFIELD(TPTR↑.CODEWORD,
XWDISP_START, XWDISP_LEN,
GETSIGNEDFIELD(TPTR↑.CODEWORD,
XWDISP_START,XWDISP_LEN)
+ TPC)
end (*non PR-style jump*);
end (*valid JUMPDEST*);
if FORCE2 then
begin (*force two-word jump*)
while NXTPC-CURPC < 2*WORDUNITS do
INSERT_NOP;
if not (NXTPC-CURPC = 2*WORDUNITS) then
ASSERTFAIL('CODE_CONC008')
(*else was already > 2 words*)
end (*force two-word jump*)
else
begin (*normal jump*)
if TPC > CURPC then
begin (*forward jump*)
if(GETFIELD(IPTR↑.CODEWORD,PR_START,PR_LEN)=1)
and BIGJUMPS then
(*We assumed extended OPND2 since it was
forward, but managed to emit PR-style -
so insert NOP to keep PC straight*)
INSERT_NOP
end (*forward jump*)
end (*normal jump*)
end (*any VJOP*)
end (*not VFAKEOP*);
IPTR := NXTIPTR;
CURPC := NXTPC
end (*while IPTR <> nil do*);
if not (PASS2_MAXPC = CURPC) then ASSERTFAIL('CODE_CONC009');
JUMPS_CONCRETIZED := true
end (*CONC_PASS3*);
begin (*CODE_CONCRETIZER*)
CONC_PASS1;
PEEPHOLE_OPTIMIZER(PASS2_NEEDED);
if PASS2_NEEDED then CONC_PASS2;
CONC_PASS3
end (*CODE_CONCRETIZER*);
(** OBJECT_MODULE_SEGMENT_CLASS: INIT_SEGMENT GEN_SEGMENT FIXDISP OPEN_SEGMENT CLOSE_SEGMENT CLEAROUT_TXTBUF OPEN_TXT CLOSE_TXT OUT_TXT **)
(**)
procedure INIT_SEGMENT;
var R : S1REGISTER;
G : S1GBL;
H : integer;
begin
NEW(OLDNP);
MAINCODE := EMPTYCODELIST;
JUMPS_CONCRETIZED := false;
NEWCODEREC(NEWINSTREC);
STRINGAREA := EMPTYCODELIST;
NXTSTRDISP := 0;
STRINGFIXLIST := EMPTYCODELIST;
TOP := BOT-1;
for R := FIRSTS1REG to LASTS1REG do
begin
RISFREE[R] := true;
RPWORD[R] := RSINGLE; (*PBK*)
end;
for G := FIRSTS1GBL to LASTS1GBL do
begin
GISFREE[G] := true;
end;
MINTMPS1REG := MINPARS1REG;
for H := 0 to LBLHTSIZEM1 do
LBLHASHTAB[H] := nil;
EVALSAVE.SIZE := 0;
EVALSAVE.FIXLIST := EMPTYCODELIST;
EVALSAVE.NEGFIXLIST := EMPTYCODELIST;
NEG_SHIFT_FIXLIST := EMPTYCODELIST;
MSTTOP := 0;
with MSTSTK[MSTTOP] do
begin
LASTEXPR := BOT - 1;
EVALSAVESTART := 0;
end;
REALTBL := EMPTYCODELIST;
SETTBL := EMPTYCODELIST;
BOUNDTBL := EMPTYCODELIST;
LOCTBL := EMPTYCODELIST;
REALFIXLIST := EMPTYCODELIST;
SETFIXLIST := EMPTYCODELIST;
BOUNDFIXLIST := EMPTYCODELIST;
PROCTBL.NPROCS := 0;
PROCTBL.FIRST := nil;
end (*INIT_SEGMENT*);
procedure GEN_SEGMENT;
const
MAXTXTBUFNWORDS = 4; (*for TXT records to fit in 80 columns*)
var
PTR, IPTR, NXTIPTR, TPTR, OPLOC : A_CODEREC;
VAL, DSP : integer;
I : 0..LBLHTSIZEM1;
LPTR : A_LBLHASHENT;
PPTR : A_PROCENT;
NXTPC, MAXPC : integer;
PITPC : integer; (*address of PIT in segment*)
S1PC : integer;
NREF, INX : integer;
CURS1OPC : S1OPCODE;
ICW, W, W1, W2 : S1WORD;
TXTBUF : array [1..MAXTXTBUFNWORDS] of S1WORD;
TXTBUFNWORDS : 0..MAXTXTBUFNWORDS;
TXTBUFFSTADR : S1RELADR;
TXTBUFNXTADR : S1RELADR;
RADR : S1RELADR;
procedure FIXDISP(WORDLOC : A_CODEREC; FIXVAL : integer);
(*Fix up the extended word addressed by WORDLOC by adding the
FIXVAL to the displacement.*)
var DSP : integer;
begin
DSP := GETSIGNEDFIELD(WORDLOC↑.CODEWORD,
XWDISP_START,XWDISP_LEN);
DSP := DSP + FIXVAL;
if (DSP > MAXS1DISP) or (DSP < MINS1DISP) then
ERROR(WINVALID_DISPLACEMENT)
else
PUTFIELD(WORDLOC↑.CODEWORD,XWDISP_START,XWDISP_LEN,DSP)
end (*FIXDISP*);
procedure OPEN_SEGMENT(NESD, NTXT, NESR, NRLD : integer);
(*Prepare to output the segment. NESD is the number of
external symbols which will be defined. NTXT is the number
of words of TXT which will be output. NESR is the number of
external symbols which will be referenced. NRLD is the
number of words which will be relocated. If any of these
parameters is not known exactly, specify -1.*)
begin
(*No-op for now with the intermediate loader format*)
end (*OPEN_SEGMENT*);
procedure CLOSE_SEGMENT;
(*Close segment output.*)
begin
WRITELN(PRR,'EOM ',CURPROCXN.NAM,' Comments or insults');
end (*CLOSE_SEGMENT*);
procedure CLEAROUT_TXTBUF;
(*Clear out the TXTBUF by outputting a TXT record if any text
is contained therein. Count the words output.*) (*LCW*)
var I : 1..MAXTXTBUFNWORDS;
S_FSTADR : CHAR12;
S_TXTBFW : CHAR12;
begin
WORD_CNT := WORD_CNT + TXTBUFNWORDS; (*LCW*)
if TXTBUFNWORDS > 0 then
begin
CVOS_12(S_FSTADR,TXTBUFFSTADR);
WRITE(PRR,'TXT ',1:8,' ',S_FSTADR,' ',TXTBUFNWORDS:2);
for I := 1 to TXTBUFNWORDS do
begin
CVOS_S1WORD_12(S_TXTBFW,TXTBUF[I]);
WRITE(PRR,' ',S_TXTBFW);
end;
WRITELN(PRR);
TXTBUFNWORDS := 0
end
end (*CLEAROUT_TXTBUF*);
procedure OPEN_TXT;
(*Prepares to output the TXT part of the module.*)
begin
TXTBUFNWORDS := 0
end (*OPEN_TXT*);
procedure CLOSE_TXT;
(*Closes off all pending TXT part output.*)
begin
CLEAROUT_TXTBUF
end (*CLOSE_TXT*);
procedure OUT_TXT(var ADR : S1RELADR; WORD : S1WORD);
(*Outputs the word WORD as part of a TXT record, to be loaded
at address ADR. Increments ADR by WORDUNITS to prepare for
next word.*)
begin
if (TXTBUFNWORDS >= MAXTXTBUFNWORDS) or (ADR <> TXTBUFNXTADR)
then
CLEAROUT_TXTBUF;
if TXTBUFNWORDS = 0 then
begin
TXTBUFFSTADR := ADR;
TXTBUFNXTADR := ADR
end;
TXTBUFNWORDS := TXTBUFNWORDS + 1;
TXTBUF[TXTBUFNWORDS] := WORD;
ADR := ADR + WORDUNITS;
TXTBUFNXTADR := ADR
end (*OUT_TXT*);
(** OBJECT_MODULE_SEGMENT_CLASS: OPEN_SEG CLOSE_SEG OUT_SEG OPEN_ESD CLOSE_ESD OUT_ESD OPEN_ESR CLOSE_ESR OUT_ESR OPEN_RLD CLOSE_RLD OUT_RLD **)
(**)
procedure OPEN_SEG;
(*Prepares to output the SEG part of the module.*)
begin
(*No-op for now with the intermediate loader format*)
end (*OPEN_SEG*);
procedure CLOSE_SEG;
(*Closes off all pending SEG part output.*)
begin
(*No-op for now with the intermediate loader format*)
end (*CLOSE_SEG*);
procedure OUT_SEG(SNAM : ZSYMBOL; STYP : ZSEGTYPE;
SEGINX : ESDINDEX; SADR : S1RELADR;
SLEN : integer; SACMOD : CHAR17);
(*Outputs a SEG entry for symbol SNAM of type STYP, segment
index SEGINX, address SADR, and length SLEN.*)
var S_SADR, S_SLEN : CHAR12;
begin
CVOS_12(S_SADR, SADR);
CVOS_12(S_SLEN, SLEN);
WRITELN(PRR,'SEG ',SNAM:8,' ',ZSEGTYPE_TO_CHARS[STYP]:4,
' ',SEGINX:8,' ',S_SADR,' ',S_SLEN,' ',SACMOD);
end (*OUT_SEG*);
procedure OPEN_ESD;
(*Prepares to output the ESD part of the module.*)
begin
(*No-op for now with the intermediate loader format*)
end (*OPEN_ESD*);
procedure CLOSE_ESD;
(*Closes off all pending ESD part output.*)
begin
(*No-op for now with the intermediate loader format*)
end (*CLOSE_ESD*);
procedure OUT_ESD(SNAM : ZSYMBOL; STYP : ZESDTYPE;
SEGINX : ESDINDEX; SADR : S1RELADR;
INX : ESDINDEX);
(*Outputs an ESD entry for symbol SNAM of type STYP, segment
index SEGINX, address SADR, and index INX.*)
var S_SADR : CHAR12;
begin
CVOS_12(S_SADR, SADR);
WRITELN(PRR,'ESD ',SNAM:8,' ',ZESDTYPE_TO_CHARS[STYP]:4,
' ',SEGINX:8,' ',S_SADR,' ',INX:8);
end (*OUT_ESD*);
procedure OPEN_ESR;
(*Prepares to output the ESR part of the module.*)
begin
(*No-op for now with the intermediate loader format*)
end (*OPEN_ESR*);
procedure CLOSE_ESR;
(*Closes off all pending ESR part output.*)
begin
(*No-op for now with the intermediate loader format*)
end (*CLOSE_ESR*);
procedure OUT_ESR(SNAM : ZSYMBOL; STYP : ZESRTYPE;
INX : ESRINDEX);
(*Outputs an ESR entry for symbol SNAM of type STYP and index
INX.*)
begin
WRITELN(PRR,
'ESR ',SNAM:8,' ',ZESRTYPE_TO_CHARS[STYP]:4,' ',INX:8)
end (*OUT_ESR*);
procedure OPEN_RLD;
(*Prepares to output the RLD part of the module.*)
begin
(*No-op for now with the intermediate loader format*)
end (*OPEN_RLD*);
procedure CLOSE_RLD;
(*Closes off all pending RLD part output.*)
begin
(*No-op for now with the intermediate loader format*)
end (*CLOSE_RLD*);
procedure OUT_RLD(SNAM : ZSYMBOL; IXFLAG : ZESDESRSEG;
SOPR : ZOPR; SEGINX : ESDINDEX;
SADR : S1RELADR; INX : ZINDEX);
(*Outputs an RLD entry for symbol SNAM of type IXFLAG, operation
SOPR, segment index SEGINX, address SADR, and index INX.*)
var S_SADR : CHAR12;
begin
CVOS_12(S_SADR, SADR);
WRITELN(PRR,'RLD ',SNAM:8,' ',ZIXFLAG_TO_CHAR[IXFLAG]:1,
' ',ZOPR_TO_CHARS[SOPR]:2,' ',SEGINX:8,
' ',S_SADR,' ',INX:8)
end (*OUT_RLD*);
begin (*GEN_SEGMENT*)
PTR := EVALSAVE.FIXLIST.FIRST;
while PTR <> nil do
begin
FIXOPND2(PTR↑.CODEPTR,EVALSAVE.SIZE);
PTR := PTR↑.NEXTPTR
end;
PTR := EVALSAVE.NEGFIXLIST.FIRST;
VAL := - EVALSAVE.SIZE;
while PTR <> nil do
begin
FIXOPND2(PTR↑.CODEPTR,VAL);
PTR := PTR↑.NEXTPTR
end;
PTR := NEG_SHIFT_FIXLIST.FIRST;
while PTR <> nil do
begin
OPLOC := PTR_OPNDXWD(PTR↑.CODEPTR,OPND2_START);
if not (OPLOC<>nil) then ASSERTFAIL('GEN_SEGME001');
DSP := GETSIGNEDFIELD(OPLOC↑.CODEWORD,
XWDISP_START,XWDISP_LEN);
DSP := (-DSP) * DALIGNMUL;
PUTFIELD(OPLOC↑.CODEWORD,XWDISP_START,XWDISP_LEN,DSP);
PTR := PTR↑.NEXTPTR
end;
(*Check for undefined labels*)
for I := 0 to LBLHTSIZEM1 do
begin
LPTR := LBLHASHTAB[I];
while LPTR <> nil do
begin
if not LPTR↑.DEFINED then
begin
ERRINT1 := LPTR↑.LBLNUM;
ERROR(WL_LPTR_LBLNUM_UNDEFINED)
end;
LPTR := LPTR↑.NEXTPTR
end;
end (*for I := 0 to LBLHTSIZEM1*);
if TOP <> BOT-1 then
ERROR (WSTACK_LEFT_NONEMPTY_IN_LAST_SEGMENT);
if MSTTOP <> 0 then
ERROR (WMST_WITHOUT_CUP_IN_LAST_SEGMENT);
CODE_CONCRETIZER;
(** OBJECT_MODULE_SEGMENT_CLASS **)
(**)
(*Resolve string, real, set literals...*)
PTR := STRINGFIXLIST.FIRST;
while PTR <> nil do
begin
FIXDISP(PTR↑.CODEPTR,CURPC);
PTR := PTR↑.NEXTPTR
end;
CURPC := CURPC + STRINGAREA.NWORDS * WORDUNITS;
PTR := REALFIXLIST.FIRST;
while PTR <> nil do
begin
FIXDISP(PTR↑.CODEPTR,CURPC);
PTR := PTR↑.NEXTPTR
end;
CURPC := CURPC + REALTBL.NWORDS * WORDUNITS;
PTR := SETFIXLIST.FIRST;
while PTR <> nil do
begin
FIXDISP(PTR↑.CODEPTR,CURPC);
PTR := PTR↑.NEXTPTR
end;
CURPC := CURPC + SETTBL.NWORDS * WORDUNITS;
PTR := BOUNDFIXLIST.FIRST;
while PTR <> nil do
begin
FIXDISP(PTR↑.CODEPTR,CURPC);
PTR := PTR↑.NEXTPTR
end;
CURPC := CURPC + BOUNDTBL.NWORDS * WORDUNITS;
PITPC := CURPC;
if DEBUG then
begin
IPTR := MAINCODE.FIRST;
S1PC := SEG_EP_RELPC;
while IPTR <> nil do
begin
CURS1OPC := GETS1OPCODE(IPTR);
ICW := IPTR↑.CODEWORD;
case OPFORMAT[CURS1OPC] of
VFAKEOP:
if CURS1OPC = XPLOC then
begin (*might emit PLOCs also*)
INTEGER_TO_S1WORD(W,S1PC);
EMIT_S1WORD(LOCTBL,W)
end
(*else ignore it*);
VTOP, VXOP, VSOP:
begin
S1PC := S1PC + WORDUNITS;
if GETFIELD(ICW,OPND1X_START,OPND1X_LEN) = 1 then
S1PC := S1PC + WORDUNITS;
if GETFIELD(ICW,OPND2X_START,OPND2X_LEN) = 1 then
S1PC := S1PC + WORDUNITS
end (*VTOP, VXOP, VSOP*);
VJOP:
begin
S1PC := S1PC + WORDUNITS;
if GETFIELD(ICW,OPND1X_START,OPND1X_LEN) = 1 then
S1PC := S1PC + WORDUNITS;
if (GETFIELD(ICW,PR_START,PR_LEN) = 0) and
(GETFIELD(ICW,OPND2X_START,OPND2X_LEN) = 1) then
S1PC := S1PC + WORDUNITS
end (*VJOP*)
end (*case*);
IPTR := NEXT_INSTRUCTION(IPTR);
end (*while IPTR <> nil*);
CURPC := CURPC + LOCTBL.NWORDS * WORDUNITS
end (*if DEBUG*);
if ASM then
begin
WRITELN(OUTPUT,'************************** ;START OF ',
CURPROCXN.NAM,' ',CURPROC);
IPTR := MAINCODE.FIRST;
S1PC := SEG_EP_RELPC;
while IPTR <> nil do
begin
DISASSEMBLE(S1PC,IPTR);
IPTR := NEXT_INSTRUCTION(IPTR)
end (*while IPTR <> nil*);
WRITELN(OUTPUT);
WRITE(OUTPUT,chr(12)) (*12 dec = 14 oct = FF (form feed) *)
end (*if ASM then*);
IPTR := MAINCODE.FIRST; (*LCW*)
while IPTR <> nil do (*LCW*)
begin (*LCW*)
S1OP_CNT[GETS1OPCODE(IPTR)] := S1OP_CNT[GETS1OPCODE(IPTR)] + 1; (*LCW*)
IPTR := NEXT_INSTRUCTION(IPTR); (*LCW*)
end; (*LCW*)
(**** Output the segment to the loader file... ****)
MAXPC := CURPC;
NREF := 0; PPTR := PROCTBL.FIRST;
while PPTR <> nil do
begin
NREF := NREF + PPTR↑.FIXLIST.NWORDS;
PPTR := PPTR↑.NEXTPTR
end;
OPEN_SEGMENT(1,MAXPC div WORDUNITS,PROCTBL.NPROCS,2*NREF);
(*Output the SEG entries...*)
OPEN_SEG;
OUT_SEG(CURPROCXN.NAM,ZIS,1,SEG_START_RELPC,MAXPC-SEG_START_RELPC,
'IN RA ');
CLOSE_SEG;
(*Output the ESD entries...*)
OPEN_ESD;
OUT_ESD(CURPROCXN.NAM,ZIN,1,SEG_START_RELPC,1);
CLOSE_ESD;
(** OBJECT_MODULE_SEGMENT_CLASS **)
(**)
(*Output the TXT entries...*)
OPEN_TXT;
CURPC := SEG_START_RELPC;
ZSYMBOL_TO_S1WORDS(W1,W2,CURPROCXN.NAM);
OUT_TXT(CURPC,W1);
OUT_TXT(CURPC,W2);
W := ZEROS1WORD;
if DEBUG then PUTFIELD(W,0,1,1);
PUTFIELD(W,1,5,LVL_TO_S1REG[CURLVL]);
OUT_TXT(CURPC,W);
INTEGER_TO_S1WORD(W,PITPC);
OUT_TXT(CURPC,W);
IPTR := MAINCODE.FIRST;
if not (CURPC = SEG_EP_RELPC) then ASSERTFAIL('GEN_SEGME002');
while IPTR <> nil do
begin
NXTIPTR := NEXT_INSTRUCTION(IPTR);
NXTPC := CURPC;
CURS1OPC := GETS1OPCODE(IPTR);
ICW := IPTR↑.CODEWORD;
case OPFORMAT[CURS1OPC] of
VFAKEOP:
(*Ignore it*);
VTOP, VXOP, VSOP:
begin
OUT_TXT(CURPC,ICW);
NXTPC := NXTPC + WORDUNITS;
TPTR := IPTR↑.NEXTPTR;
if GETFIELD(ICW,OPND2X_START,OPND2X_LEN) = 1 then
begin (*extended OPND2*)
NXTPC := NXTPC + WORDUNITS;
OUT_TXT(CURPC,TPTR↑.CODEWORD);
TPTR := TPTR↑.NEXTPTR
end;
if GETFIELD(ICW,OPND1X_START,OPND1X_LEN) = 1 then
begin (*extended OPND1*)
NXTPC := NXTPC + WORDUNITS;
OUT_TXT(CURPC,TPTR↑.CODEWORD);
TPTR := TPTR↑.NEXTPTR
end
end (*VTOP, VXOP, VSOP*);
VJOP:
begin
OUT_TXT(CURPC,ICW);
NXTPC := NXTPC + WORDUNITS;
TPTR := IPTR↑.NEXTPTR;
if (GETFIELD(ICW,PR_START,PR_LEN) = 0)
and (GETFIELD(ICW,OPND2X_START,OPND2X_LEN) = 1) then
begin (*extended OPND2*)
NXTPC := NXTPC + WORDUNITS;
OUT_TXT(CURPC,TPTR↑.CODEWORD);
TPTR := TPTR↑.NEXTPTR
end;
if GETFIELD(ICW,OPND1X_START,OPND1X_LEN) = 1 then
begin (*extended OPND1*)
NXTPC := NXTPC + WORDUNITS;
OUT_TXT(CURPC,TPTR↑.CODEWORD);
TPTR := TPTR↑.NEXTPTR
end
end (*VJOP*)
end (*case*);
IPTR := NXTIPTR;
if not (CURPC = NXTPC) then ASSERTFAIL('GEN_SEGME003')
end (*while IPTR <> nil do*);
PTR := STRINGAREA.FIRST;
while PTR <> nil do
begin
OUT_TXT(CURPC,PTR↑.CODEWORD);
PTR := PTR↑.NEXTPTR
end;
PTR := REALTBL.FIRST;
while PTR <> nil do
begin
OUT_TXT(CURPC,PTR↑.CODEWORD);
PTR := PTR↑.NEXTPTR
end;
PTR := SETTBL.FIRST;
while PTR <> nil do
begin
OUT_TXT(CURPC,PTR↑.CODEWORD);
PTR := PTR↑.NEXTPTR
end;
PTR := BOUNDTBL.FIRST;
while PTR <> nil do
begin
OUT_TXT(CURPC,PTR↑.CODEWORD);
PTR := PTR↑.NEXTPTR
end;
if not (CURPC = PITPC) then ASSERTFAIL('GEN_SEGME004');
PTR := LOCTBL.FIRST;
while PTR <> nil do
begin
OUT_TXT(CURPC,PTR↑.CODEWORD);
PTR := PTR↑.NEXTPTR
end;
if not (CURPC = MAXPC) then ASSERTFAIL('GEN_SEGME005');
CLOSE_TXT;
(*Output the ESR entries...*)
OPEN_ESR;
INX := 1;
PPTR := PROCTBL.FIRST;
while PPTR <> nil do
begin
OUT_ESR(PPTR↑.NAME,ZIR,INX);
INX := INX + 1;
PPTR := PPTR↑.NEXTPTR
end;
CLOSE_ESR;
(*Output the RLD entries...*)
OPEN_RLD;
INX := 1;
PPTR := PROCTBL.FIRST;
while PPTR <> nil do
begin
PTR := PPTR↑.FIXLIST.FIRST;
while PTR <> nil do
begin
RADR := -GETSIGNEDFIELD(PTR↑.CODEPTR↑.CODEWORD,
XWADDR_START,XWADDR_LEN) (*EJG*)
+ SEG_EP_RELPC + WORDUNITS;
(*A procedure reference operand starts out with a
displacement of SEG_EP_RELPC. During concretization,
it has the PC value subtracted from it. Thus
-GETSIGNEDFIELD(...)+SEG_EP_RELPC is the PC value of
the JSR instruction (distance from the beginning of
the module), and so adding WORDUNITS yields the PC
value of the operand itself.*)
OUT_RLD( PPTR↑.NAME,ZESR, ZPLUS,1,RADR,INX);
(*add callee seg addr*)
OUT_RLD(CURPROCXN.NAM,ZESD,ZMINUS,1,RADR, 1);
(*subtract caller seg addr*)
PTR := PTR↑.NEXTPTR
end;
INX := INX + 1;
PPTR := PPTR↑.NEXTPTR
end;
CLOSE_RLD;
CLOSE_SEGMENT;
OLDINSTREC := nil; (*So debugging class will survive.*)
NEWINSTREC := nil;
TOP := BOT-1;
MSTTOP := 0;
(* RELEASE(OLDNP); *) (*X10S1*)
DISPOSE(OLDNP); (*X10S1*)
end (*GEN_SEGMENT*);
(** CALLSTANDARD_CLASS: SAVE_PARMREGS RESTORE_PARMREGS CALLSTANDARD GENCALL ONE_ARG TWO_SINGLE_ARGS CHECKFILADR ALLOC_EXCESS EXCESS_ARG DEALLOC_EXCESS CHECK_REF_PARM RESULT_PARM **)
(**)
procedure SAVE_PARMREGS;
(*Archive all the parmregs to the parmreg save area
in order to make all variables uniformly addressable,
or in order to free the registers.*)
(* Shortened to use MOVMS_N 5 DEC 78 ALS *)
var PREG : 0..MAXPAREG;
LASTPREG : -1..MAXPAREGM1;
OPND1, OPND2 : OPERAND;
MOVENUM : 1..MAXMOVMS;
begin
with NESTDISPLAY[CURLVL] do
begin
PREG := 0;
LASTPREG := REGPARMAREA div WORDUNITS - 1;
if PREG <= LASTPREG then
begin
REGDISP_OPERAND (OPND1, DISPLAY,
-(OFFSET_IN_VARS + SECONDPARMAREA + FIRSTPARMAREA));
REG_OPERAND (OPND2, PRM_TO_S1REG [PREG]);
MOVENUM := MIN (MAXMOVMS, (LASTPREG-PREG+1));
EMITXOP (MOVMQ_N[MOVENUM], OPND1, OPND2);
PREG := PREG + MOVENUM;
end;
end;
end (*SAVE_PARMREGS*);
procedure RESTORE_PARMREGS;
(*Restore the parmregs from the save area.*)
(* Shortened to use MOVMS_N 5 Dec 78 ALS *)
var PREG : 0..MAXPAREG;
LASTPREG : -1..MAXPAREGM1;
OPND1, OPND2 : OPERAND;
MOVENUM : 1..MAXMOVMS;
begin
with NESTDISPLAY[CURLVL] do
begin
PREG := 0;
LASTPREG := REGPARMAREA div WORDUNITS - 1;
if PREG <= LASTPREG then
begin
REG_OPERAND (OPND1, PRM_TO_S1REG [PREG]);
REGDISP_OPERAND (OPND2, DISPLAY,
-(OFFSET_IN_VARS + SECONDPARMAREA + FIRSTPARMAREA));
MOVENUM := MIN (MAXMOVMS, (LASTPREG-PREG+1));
EMITXOP (MOVMQ_N[MOVENUM], OPND1, OPND2);
PREG := PREG + MOVENUM;
end;
end;
end (*RESTORE_PARMREGS*);
procedure CALLSTANDARD;
(*Figure out which standard procedure is being called, load its
arguments into the proper places, and generate the call.*)
var OPNDR, OPND1, OPND2, OPNDI1, OPNDI2 : OPERAND;
CSP : P_STANDARDPROC;
RESCODESTART : A_CODEREC;
RESTYPE : OPNDTYPE;
SKIPLOC : A_CODEREC;
SKIP1LOC, SKIP2LOC : A_CODEREC; (*BNDTRPKLU*)
FAKE_REF : boolean;
FAKE_PARMREG : S1REGISTER;
FAKE_PARMDISP : integer;
procedure GENCALL (BOTTOMPARM : STKINX);
(*Load the stack (except for parms)
to prevent side effects, and generate the JSR instruction,
with fixup information.*)
var CSPNAM : NAMEREC;
OPNDR, OPND2 : OPERAND;
begin
REG_OPERAND (OPNDR, LVL_TO_S1REG[2]);
EXT_REGADDR_OPERAND (OPND2, S1RPC, SEG_EP_RELPC); (*EJG*)
OPND2.FIXUP := XTRNSYMFIX;
CSPNAM.NAM := '$PCSP '; (*can be optimized to 'OWN' var*)
CSPNAM.LEN := 8;
CSPNAM.NAM[6] := NAM1.NAM[1];
CSPNAM.NAM[7] := NAM1.NAM[2];
CSPNAM.NAM[8] := NAM1.NAM[3];
UPD_PROCTBL (OPND2.FIXPTR, CSPNAM.NAM);
LOADSTACKEXCEPT (BOTTOMPARM, TOP);
EMITJOP (XJSR, 0, OPNDR, OPND2, nil);
end (*GENCALL*);
procedure ONE_ARG (ARG : STKINX; TYP : OPNDTYPE);
(*Load RTB with the argument, coercing to type TYP as needed.*)
begin
if not RISFREE[S1RTB] and (RTBUSER <> ARG) then
MOVE_AND_FREE_RTB;
COERCE_AND_MOVE_QUANTITY (OPNDRTB, ARG, TYP);
FREEDATUMREGS (ARG);
end (*ONE_ARG*);
procedure TWO_SINGLE_ARGS (ARG1, ARG2 : STKINX;
TYP1, TYP2 : OPNDTYPE);
(*Load RTB with two singleword arguments, coercing as needed.*)
var OPNDR : OPERAND;
begin
if not (not IS_DOUBLE[TYP1] and not IS_DOUBLE[TYP2]) then
ASSERTFAIL('TWO_SINGL001');
COERCE_DATUM (ARG1, TYP1);
if not RISFREE[S1RTB] and not((RTBUSER=ARG1) or (RTBUSER=ARG2))
then MOVE_AND_FREE_RTB;
REG_OPERAND (OPNDR, succ(S1RTB) );
COERCE_AND_MOVE_QUANTITY (OPNDR, ARG2, TYP2);
MOVE_QUANTITY (OPNDRTB, ARG1);
FREEDATUMREGS (ARG1);
FREEDATUMREGS (ARG2);
end (*TWO_SINGLE_ARGS*);
procedure CHECKFILADR (STE : STKINX);
(*Verify that STK[STE] is an address in (1,LCIOFILADR).*)
begin
if STK[STE].DTYPE <> TYPA then
ERROR (WFILE_ADDRESS_NEEDED)
else if not DATUM_IS_FILADR(STE) then
ERROR (WSIO_DIDNT_SEE_FILEADDR);
end (*CHECKFILADR*);
procedure ALLOC_EXCESS (EXCWRDS : integer);
(*Allocate stack space for EXCWRDS excess parameter words.*)
var OPND2 : OPERAND;
begin
IMM_OPERAND (OPND2, EXCWRDS*WORDUNITS);
EMITXOP (XADJSP_UP, OPNDRSP, OPND2)
end (*ALLOC_EXCESS*);
procedure EXCESS_ARG (NUM, TOT : integer;
ARG : STKINX; TYP : OPNDTYPE);
(*Store the argument into the NUMth excess parm location
in a block of TOT, coercing to type TYP if needed.*)
var OPND1 : OPERAND;
begin
REGDISP_OPERAND (OPND1, S1RSP, -(TOT-NUM+1) * WORDUNITS);
COERCE_AND_MOVE_QUANTITY (OPND1, ARG, TYP);
FREEDATUMREGS (ARG);
end (*EXCESS_ARGS*);
procedure DEALLOC_EXCESS (EXCWRDS : integer);
(*Deallocate EXCWRDS of stack space.*)
var OPND2 : OPERAND;
begin
IMM_OPERAND (OPND2, EXCWRDS*WORDUNITS);
EMITTOP(XSUB_S, 0, OPNDRSP, OPND2);
end (*DEALLOC_EXCESS*);
procedure CHECK_REF_PARM (STE : STKINX);
(*The datum is the address of a reference parameter
(e.g. for a READ). If the reference parameter
is a local parm in a register, TRANSLATE_LVLDSP
has already changed the address to that of the
corresponding save location. We must finish
the job here by emitting moves in one or two
directions to fake the reference parameter
by a value result parameter. This procedure
merely notes whether such a simulation may be
necessary.*)
var FIRSTPARM : integer;
begin
with STK[STE], NESTDISPLAY[CURLVL] do
begin
if not ( DTYPE = TYPA) then ASSERTFAIL('CHECK_REF001');
FIRSTPARM := LCBEFPAR - LOCALDATATRANSLATION;
if (NVPAS = 0) and (FPA.WHICH = MEM)
and (FPA.MEMADR.LVL = CURLVL)
and (FIRSTPARM <= FPA.MEMADR.DSPLMT)
and (FPA.MEMADR.DSPLMT < FIRSTPARM+REGPARMAREA) then
begin
FAKE_REF := true;
FAKE_PARMDISP := FPA.MEMADR.DSPLMT;
FAKE_PARMREG := PRM_TO_S1REG
[(FPA.MEMADR.DSPLMT - FIRSTPARM) div WORDUNITS];
end
else
FAKE_REF := false;
end (*with*)
end (*CHECK_REF_PARM*);
procedure RESULT_PARM (DTYPE : OPNDTYPE);
(*After completing the standard procedure, copy a
(possibly modified) local regparm back into the
register from the corresponding regparm save
location.
Note : no VALUE_PARM procedure is needed at
present because reference parms are only used
by standard procs if they wish to achieve result
parms.*)
var OPND1, OPND2 : OPERAND;
begin
if not ( FAKE_REF) then ASSERTFAIL('RESLT_PRM001');
REG_OPERAND (OPND1, FAKE_PARMREG);
REGDISP_OPERAND (OPND2, DISPLAY, FAKE_PARMDISP);
EMITXOP (MOV_X_X[DTYPE], OPND1, OPND2)
end (*RESULT_PARM*);
begin (*CALLSTANDARD*)
CSP := NAME_TO_CSP(NAM1);
case CSP of
QATN, QEXP, QSIN, QCOS, QLOG, QSQT, QCLK :
begin
if CSP = QCLK then ONE_ARG (TOP, TYPI)
else ONE_ARG (TOP, TYPR);
GENCALL (TOP);
REG_DATUM (TOP, STK[TOP].CODESTART, STK[TOP].DTYPE,S1RTB);
if CSP = QCLK then ALLOCRG (S1RTB) else ALLOCRP (S1RTB);
RTBUSER := TOP;
RTBDOUB := IS_DOUBLE[STK[TOP].DTYPE];
end (*QATN,...,QCLK*);
QXIT :
begin
ONE_ARG (TOP, TYPI);
GENCALL (TOP);
POPTOP;
end (*QXIT*);
QTRP :
begin
SAVE_PARMREGS;
TWO_SINGLE_ARGS (TOP-1, TOP, TYPI, TYPA);
GENCALL (TOP-1);
POPTOP; POPTOP;
RESTORE_PARMREGS;
end (*QTRP*);
QGET, QPUT, QRLN, QWLN, QRES, QREW :
begin
CHECKFILADR (TOP);
GENCALL (TOP);
end (*QGET,...,QREW*);
QRDB :
begin
CHECKFILADR (TOP-1);
CHECK_REF_PARM (TOP);
ONE_ARG (TOP, TYPA);
GENCALL (TOP-1);
if FAKE_REF then RESULT_PARM (TYPB);
POPTOP;
end (*QRDB*);
QRDC :
begin
CHECKFILADR (TOP-1);
CHECK_REF_PARM (TOP);
ONE_ARG (TOP, TYPA);
GENCALL (TOP-1);
if FAKE_REF then RESULT_PARM (TYPC);
POPTOP;
end (*QRDC*);
QRDI :
begin
CHECKFILADR (TOP-1);
CHECK_REF_PARM (TOP);
ONE_ARG (TOP, TYPA);
GENCALL (TOP-1);
if FAKE_REF then RESULT_PARM (TYPI);
POPTOP;
end (*QRDI*);
QRDR :
begin
CHECKFILADR (TOP-1);
CHECK_REF_PARM (TOP);
ONE_ARG (TOP, TYPA);
GENCALL (TOP-1);
if FAKE_REF then RESULT_PARM (TYPR);
POPTOP;
end (*QRDR*);
QRDS :
begin
CHECKFILADR (TOP-2);
TWO_SINGLE_ARGS (TOP-1, TOP, TYPA, TYPI);
GENCALL (TOP-2);
POPTOP; POPTOP;
end (*QRDS*);
QWRB :
begin
CHECKFILADR (TOP-2);
TWO_SINGLE_ARGS (TOP-1, TOP, TYPB, TYPI);
GENCALL (TOP-2);
POPTOP; POPTOP;
end (*QWRB*);
QWRC :
begin
CHECKFILADR (TOP-2);
TWO_SINGLE_ARGS (TOP-1, TOP, TYPC, TYPI);
GENCALL (TOP-2);
POPTOP; POPTOP;
end (*QWRC*);
QWRI :
begin
CHECKFILADR (TOP-2);
TWO_SINGLE_ARGS (TOP-1, TOP, TYPI, TYPI);
GENCALL (TOP-2);
POPTOP; POPTOP;
end (*QWRI*);
QWRR :
begin
POPTOP; (*Ignore fraction length for now. LCW*)
CHECKFILADR (TOP-2);
ALLOC_EXCESS (1);
EXCESS_ARG (1, 1, TOP, TYPI);
ONE_ARG (TOP-1, TYPR);
GENCALL (TOP-2);
DEALLOC_EXCESS (1);
POPTOP; POPTOP;
end (*QWRR*);
QWRS :
begin
CHECKFILADR (TOP-3);
ALLOC_EXCESS (1);
EXCESS_ARG (1, 1, TOP, TYPI);
TWO_SINGLE_ARGS (TOP-2, TOP-1, TYPA, TYPI);
GENCALL (TOP-3);
DEALLOC_EXCESS (1);
POPTOP; POPTOP; POPTOP;
end (*QWRS*);
QELN, QEOF :
begin
CHECKFILADR (TOP);
if not RISFREE[S1RTB] then MOVE_AND_FREE_RTB;
GENCALL (TOP);
(*Insert the boolean answer under the FILADR.*)
PUSHTOP;
if not (RISFREE[S1RTB] or (RTBUSER<>TOP-1)) then
ASSERTFAIL('QELN,QEOF001');
STK[TOP] := STK[TOP-1];
(*This works since datum does not include RTB.*)
REG_DATUM (TOP-1, STK[TOP-1].CODESTART,
TYPB, S1RTB);
STK[TOP-1].BREPRES := BINTVAL;
ALLOCRG (S1RTB);
RTBUSER := TOP-1;
RTBDOUB := false;
end (*QELN, QEOF*);
QSIO :
begin
REGDISP_OPERAND (OPND1,
LVL_TO_S1REG[1],
LCIOFILADR - L1LOCALDATATRANSLATION);
with STK[TOP] do
begin
if DTYPE <> TYPA then
ERROR (WSIO_WITH_NONADDRESS);
MOVE_QUANTITY (OPND1, TOP);
FREEDATUMREGS (TOP);
RESCODESTART := CODESTART;
STK[TOP] := ZERODATUM;
CODESTART := RESCODESTART;
DTYPE := TYPA;
NVPAS := 1;
VPA1.VPA.WHICH := MEM;
VPA1.VPA.MEMADR.LVL := 1;
VPA1.VPA.MEMADR.DSPLMT :=
LCIOFILADR - L1LOCALDATATRANSLATION;
end (*with STK[TOP] do*);
end (*QSIO*);
QEIO :
begin
CHECKFILADR (TOP);
POPTOP;
end (*QEIO*);
QNEW :
begin
if not IS_INTEGER[STK[TOP].DTYPE] or
(STK[TOP-1].DTYPE <> TYPA) then
ERROR (WNEW_MUST_HAVE_ADDR_AND_INT);
COERCE_DATUM (TOP, TYPI);
GET_OPERAND (OPND2, TOP);
(*Check alignment.*)
if IS_CONSTANT(TOP) then
begin
if STK[TOP].FPA.MEMADR.DSPLMT mod WORDUNITS <> 0 then
ERROR (WALIGNMENT_ERROR);
end
else if DEBUG then
begin (*Check at run time.*)
IMM_OPERAND (OPND1, WORDUNITS-1);
SKIPLOC := NEWINSTREC;
EMITSOP (XSKP_NON_S, 0, OPND1, OPND2, nil);
IMM_OPERAND (OPNDI1, 1);
IMM_OPERAND (OPNDI2, -1);
(*Check 0<=-1<=1 : fake TRAP SELF*)
(* EMITXOP (XBTRP_0_S, OPNDI1, OPNDI2); *) (*BNDTRPKLU*)
EMITJOP(XHALT,0,UNUSED_OP,ZERO_OP,NEWINSTREC); (*BNDTRPKLU*)
FIXSOP (SKIPLOC, NEWINSTREC);
end (*Check at run time.*);
REG_OPERAND (OPNDR, pred(S1RNP)); (*SP-NP pair*)
EMITXOP (XADJSP_DN, OPNDR, OPND2);
GET_ADDRESS (OPND1, TOP-1);
REG_OPERAND (OPNDR, S1RNP);
EMITXOP (XMOV_S_S, OPND1, OPNDR);
FREEDATUMREGS (TOP); POPTOP;
FREEDATUMREGS (TOP); POPTOP;
end (*QNEW*);
QSAV :
begin
if STK[TOP].DTYPE <> TYPA then
ERROR (WSAV_NEEDS_ADDR);
GET_ADDRESS (OPND1, TOP);
REG_OPERAND (OPNDR, S1RNP);
EMITXOP (XMOV_S_S, OPND1, OPNDR);
FREEDATUMREGS (TOP);
POPTOP;
end (*QSAV*);
QRST :
begin
if STK[TOP].DTYPE <> TYPA then
ERROR (WRST_NEEDS_ADDR);
if DEBUG then
begin
(* REG_OPERAND (OPNDR, S1RNP); *) (*BNDTRPKLU*)
(* GET_OPERAND (OPND2, TOP); *) (*BNDTRPKLU*)
(* EMITXOP (XBTRP_B_S, OPNDR, OPND2); *) (*BNDTRPKLU*)
GET_OPERAND (OPND2, TOP); (*BNDTRPKLU*)
ADDR_OPERAND (OPND1, S1RNPMEMADR); (*BNDTRPKLU*)
SKIP1LOC := NEWINSTREC; (*BNDTRPKLU*)
EMITSOP (XSKP_LSS_S, 0, OPND2, OPND1, nil); (*BNDTRPKLU*)
ADDR_OPERAND (OPND1, S1RNPMEMADR+WORDUNITS); (*BNDTRPKLU*)
SKIP2LOC := NEWINSTREC; (*BNDTRPKLU*)
EMITSOP (XSKP_LEQ_S, 0, OPND2, OPND1, nil); (*BNDTRPKLU*)
FIXSOP (SKIP1LOC, NEWINSTREC); (*BNDTRPKLU*)
EMITJOP (XHALT, 0, UNUSED_OP, ZERO_OP, (*BNDTRPKLU*)
NEWINSTREC); (*BNDTRPKLU*)
FIXSOP (SKIP2LOC, NEWINSTREC); (*BNDTRPKLU*)
end (*DEBUG*);
REG_OPERAND (OPNDR, S1RNP);
MOVE_QUANTITY (OPNDR, TOP);
FREEDATUMREGS (TOP);
POPTOP;
end (*QRST*);
end (*case CSP of*);
if (CSP in [QGET,QPUT,QRDB,QRDC,QRDI,QRDR,QRDS,
QRES,QREW,QRLN,QWLN,QWRB,QWRC,QWRI,QWRR,QWRS])
and (TOP <> BOT) then
ERROR (WSTACK_NOT_SINGLE)
else if (CSP in [QTRP,QXIT,QNEW,QSAV,QRST])
and (TOP <> BOT-1) then
ERROR (WSTACK_NON_EMPTY);
end (*CALLSTANDARD*);
(** ASMNXTINST_CLASS: ASMNXTINST CASE1 **)
(**)
procedure ASMNXTINST;
var
S1OP, MOVEOP : S1OPCODE;
OPND, OPND1, OPND2, OPNDR, OPNDR1, OPNDR2 : OPERAND;
RESTYPE : OPNDTYPE;
RESCODESTART : A_CODEREC;
RESDBL : boolean;
COMBINABLE, CALCULABLE : boolean;
TOOMUCH1, TOOMUCH2 : boolean;
STE, PARM, UNSIMPLE, SIMPLER, GROUP1, GROUP2 : STKINX;
PTR, NEXT : A_CODEREC;
INSTLOC, SKIPLOC, JUMPLOC, FALLTHRUJUMP : A_CODEREC;
SKIP1LOC, SKIP2LOC : A_CODEREC; (*BNDTRPKLU*)
TMPJUMPLIST : JUMPLIST;
DEST, OP1RG, OP2RG : S1REGISTER;
OP1GBL : S1GBL;
LPTR : A_LBLHASHENT;
ONE_IF_OR : BIT;
MAXFINALIND : INDIRECTION;
PR_BIT : BIT;
SP_TWIDDLE : integer;
SKIPSMALL, SKIPNOTBIG, JUMPDEFAULT, JUMPINDEXED : A_CODEREC;
FRAMESIZEPART : integer;
EXCESS : integer;
MOVENUM : 1..MAXMOVMQ;
CONSTPART : integer;
SHIFTDIST : integer;
I : integer;
STARTBIT : S1BITNUM;
PREG : 0..MAXPAREG;
LASTPREG, DESTLASTPREG : -1..MAXPAREGM1;
PWORD : NONNEGINT;
PREGS : NUMBER_OF_PAREGS;
DSPL : integer;
LABNUM : LBL_INDEX;
RTBSAVED : boolean;
RTBDATUM : STKINX;
RTBDSPL : integer;
IPTR : A_CODEREC;
S1PC : integer;
XFER_CNT : integer;
procedure CASE1;
begin
case OPC of
PABI, PABR, PNGI, PNGR :
with STK[TOP] do
begin
if OPC in [PABI,PNGI] then
if DTYPE<>TYPD then COERCE_DATUM(TOP,TYPI) else (*TYPD: OK*)
else
if not IS_REAL[DTYPE] then ERROR(WABR_OR_NGR_OF_NONREAL);
if IS_CONSTANT(TOP) then
begin
if IS_INTEGER[DTYPE] then
if OPC = PABI then
FPA.MEMADR.DSPLMT := ABS(FPA.MEMADR.DSPLMT)
else (*OPC = PNGI*)
FPA.MEMADR.DSPLMT := - FPA.MEMADR.DSPLMT
else (*IS_REAL[DTYPE]*)
if OPC = PABR then
RCNST := ABS(RCNST)
else (*OPC = PNGR*)
RCNST := - RCNST
end (*IS_CONSTANT(TOP)*)
else (*not constant*)
begin
GET_OPERAND(OPND2,TOP);
FREEDATUMREGS(TOP);
if IS_DOUBLE[DTYPE] then FINDRP else FINDRG;
REG_OPERAND(OPND1,NXTRG);
if OPC in [PABI,PABR] then S1OP := ABS_X[DTYPE]
else S1OP := NEG_X[DTYPE];
EMITXOP(S1OP,OPND1,OPND2);
REG_DATUM(TOP,CODESTART,DTYPE,NXTRG)
end (*not constant*)
end (*PABI, PABR, PNGI, PNGR*);
PSQI, PSQR :
with STK[TOP] do
begin
RESTYPE := ARITH_RESULT_TYPE[DTYPE,DTYPE];
if RESTYPE = ILLARITH then ERROR(WSQUARE_OF_INVALID_TYPE)
else
begin
COERCE_DATUM(TOP,RESTYPE);
if IS_CONSTANT(TOP) then
begin
if IS_INTEGER[RESTYPE] then
FPA.MEMADR.DSPLMT := sqr(FPA.MEMADR.DSPLMT)
else (*IS_REAL(RESTYPE)*)
RCNST := sqr(RCNST)
end (*IS_CONSTANT(TOP)*)
else (*not constant*)
begin
GET_OPERAND(OPND2,TOP);
if RESTYPE = TYPI then S1OP := XMULT_S
else if RESTYPE = TYPR then S1OP := XFMULT_S
else if RESTYPE = TYPX then S1OP := XFMULT_D
else if RESTYPE = TYPD then S1OP := XMULT_D
else if not (false) then ASSERTFAIL('PSQI,PSQR001');
ALLOC_AND_EMIT_TOP (DEST, S1OP, OPND2, OPND2,
IS_DOUBLE[RESTYPE],IS_DOUBLE[DTYPE],
IS_DOUBLE[DTYPE], TOP);
FREEREGSBUTONE(TOP,DEST);
REG_DATUM(TOP,CODESTART,RESTYPE,DEST)
end (*not constant*)
end
end (*PSQI, PSQR*);
PINC, PDEC, PPRE, PSUC :
with STK[TOP] do
begin
if OPC = PPRE then
begin TYP := DTYPE; I1 := -1; end
else if OPC = PSUC then
begin TYP := DTYPE; I1 := 1; end
else if OPC = PDEC then
I1 := -I1;
if DTYPE <> TYP then
ERROR (WINSTR_TYPE_NOT_DATUM_TYPE);
INCREMENT_DATUM (TOP, I1);
end (*PINC,...,PSUC*);
PORD :
with STK[TOP] do
begin
if not (DTYPE in [TYPQ,TYPH,TYPI,TYPD,TYPB,TYPC]) then
ERROR (WORD_NEEDS_INT_BOOLEAN_OR_CHAR);
if DTYPE in [TYPB, TYPC] then
begin
if (DTYPE=TYPB) and (BREPRES=BJUMP) then
BJUMP_TO_BINTVAL (TOP);
DTYPE := TYPQ;
end;
end (*PORD*);
PCHR :
with STK[TOP] do
if not IS_INTEGER[DTYPE] then
ERROR (WCHR_NEEDS_INT)
else
begin
COERCE_DATUM (TOP, TYPQ);
DTYPE := TYPC;
end (*PCHR*);
PFLO, PFLT :
begin
if OPC = PFLO then STE := TOP-1 else STE := TOP;
if not (STE >= BOT) then ASSERTFAIL('PFLO,PFLT001');
with STK[STE] do
begin
S1OP := FLOAT_S_X[DTYPE];
if S1OP = XILLEGAL then ERROR(WFLOAT_OF_INVALID_TYPE);
if IS_CONSTANT(STE) then
begin
RCNST := FPA.MEMADR.DSPLMT;
FPA := ZEROFPA;
DTYPE := TYPR
end
else (*not constant*)
begin
GET_OPERAND(OPND2,STE);
FREEDATUMREGS(STE);
FINDRP;
REG_OPERAND(OPND1,NXTRG);
EMITXOP(S1OP,OPND1,OPND2);
REG_DATUM(STE,CODESTART,TYPR,NXTRG)
end (*not constant*)
end (*with STK[STE] do*)
end (*PFLO, PFLT*);
PTRC :
with STK[TOP] do
begin
S1OP := FIX_DM_S_X[DTYPE];
if S1OP = XILLEGAL then ERROR(WTRUNCATE_OF_INVALID_TYPE);
if IS_CONSTANT(TOP) then
begin
FPA := ZEROFPA;
FPA.MEMADR.DSPLMT := trunc(RCNST);
RCNST := 0.0;
DTYPE := TYPI
end
else (*not constant*)
begin
GET_OPERAND(OPND2,TOP);
FREEDATUMREGS(TOP);
FINDRG;
REG_OPERAND(OPND1,NXTRG);
EMITXOP(S1OP,OPND1,OPND2);
REG_DATUM(TOP,CODESTART,TYPI,NXTRG)
end (*not constant*)
end (*PTRC*);
end (*case OPC of*)
end (*CASE1*);
(** ASMNXTINST_CLASS: CASE2 **)
(**)
procedure CASE2;
begin
case OPC of
PODD :
with STK[TOP] do
begin
if not IS_INTEGER[DTYPE] then
ERROR(WODD_REQUIRES_AN_INTEGER);
if IS_CONSTANT(TOP) then
begin
DTYPE := TYPB;
BREPRES := BINTVAL;
FPA.MEMADR.DSPLMT := ord(odd(FPA.MEMADR.DSPLMT))
end
else
begin (*not constant*)
RESCODESTART := CODESTART;
GET_OPERAND(OPND1,TOP);
IMM_OPERAND(OPND2,1);
LOADSTACKEXCEPT(TOP, TOP);
if not RISFREE[S1RTB] and (RTBUSER <> TOP) then
MOVE_AND_FREE_RTB;
FREEDATUMREGS(TOP);
SKIPLOC := NEWINSTREC;
EMITSOP(SKP_NON_X[DTYPE],0,OPND1,OPND2,nil);
EMITJOP(XJMPA,0,UNUSED_OP,ZERO_OP,nil);
FIXSOP(SKIPLOC,NEWINSTREC);
STK[TOP] := ZERODATUM;
CODESTART := RESCODESTART;
DTYPE := TYPB;
BREPRES := BJUMP;
NVPAS := 1; (*To make it not look like a constant.
Hopefully not needed.*)
FINDRG;
VPA1.VPA.WHICH := RGS;
VPA1.VPA.RGADR := NXTRG;
(*where it will go if it becomes bintval*)
BTRUELIST := EMPTYJUMPLIST;
BFALSELIST := EMPTYJUMPLIST;
BJUMPON := true;
BFALLTHRUSKIPLOC := SKIPLOC
end (*not constant*)
end (*PODD*);
PNOT :
with STK[TOP] do
begin
if DTYPE <> TYPB then
ERROR (WNOT_NEEDS_BOOLEAN);
RESCODESTART := CODESTART;
if BREPRES = BJUMP then
begin
TMPJUMPLIST := BTRUELIST;
BTRUELIST := BFALSELIST;
BFALSELIST := TMPJUMPLIST;
BJUMPON := not BJUMPON;
end (*BJUMP*)
else
begin (*BINTVAL*)
if IS_CONSTANT(TOP) then
FPA.MEMADR.DSPLMT := 1 - FPA.MEMADR.DSPLMT
else
begin (*non-constant bintval*)
GET_OPERAND (OPND1, TOP);
IMM_OPERAND (OPND2, 1);
ALLOC_AND_EMIT_TOP (DEST, XXOR_Q, OPND1, OPND2,
false, false, false, TOP);
FREEREGSBUTONE (TOP, DEST);
REG_DATUM (TOP, CODESTART, TYPB, DEST);
BREPRES := BINTVAL;
end (*non-constant bintval*);
end (*BINTVAL*);
end (*PNOT*);
PADI :
begin
COERCE_TWO_DATUMS (IS_INTEGER);
if not ((STK[TOP].DTYPE=STK[TOP-1].DTYPE) and
(STK[TOP].DTYPE in [TYPI, TYPD])) then ASSERTFAIL('PADI 001');
if STK[TOP].DTYPE = TYPI then
ADD_TOP_TWO_DATUMS
else
begin (*TYPD*)
GET_OPERAND (OPND1, TOP-1);
GET_OPERAND (OPND2, TOP);
ALLOC_AND_EMIT_TOP (DEST, XADD_D, OPND1, OPND2,
true, true, true, TOP-1);
FREEREGSBUTONE (TOP, DEST);
POPTOP;
FREEREGSBUTONE (TOP, DEST);
with STK[TOP] do
REG_DATUM (TOP, CODESTART, TYPD, DEST);
end (*TYPD*);
end (*PADI*);
PSBI :
begin
COERCE_TWO_DATUMS (IS_INTEGER);
RESCODESTART := STK[TOP-1].CODESTART;
if STK[TOP].DTYPE = TYPD then
begin
GET_OPERAND (OPND1, TOP-1);
GET_OPERAND (OPND2, TOP);
ALLOC_AND_EMIT_TOP (DEST, XSUB_D, OPND1, OPND2,
true, true, true, TOP-1);
FREEREGSBUTONE (TOP, DEST);
POPTOP;
FREEREGSBUTONE (TOP, DEST);
REG_DATUM (TOP, RESCODESTART, TYPD, DEST);
end (*TYPD*)
else
begin (*TYPI*)
COMBINABLE := false;
CALCULABLE := false;
repeat
if (STK[TOP].NVPAS=0) and (STK[TOP].FPA=ZEROFPA) then
COMBINABLE := true
else
if IS_CONSTANT(TOP) and (STK[TOP-1].FINALIND=IND0) then
COMBINABLE := true
else
begin (*not combinable*)
CONSTPART := 0;
with STK[TOP-1] do
if FINALIND = IND0 then
begin
CONSTPART := FPA.MEMADR.DSPLMT;
FPA.MEMADR.DSPLMT := 0;
end;
with STK[TOP] do
if FINALIND = IND0 then
begin
CONSTPART := CONSTPART - FPA.MEMADR.DSPLMT;
FPA.MEMADR.DSPLMT := 0;
end;
if (STK[TOP-1].NVPAS=0) and (STK[TOP-1].FPA=ZEROFPA)
then
begin (*replace hard zero by const part*)
STK[TOP-1].FPA.MEMADR.DSPLMT := CONSTPART;
CONSTPART := 0;
end
else if (STK[TOP].NVPAS=0) and (STK[TOP].FPA=ZEROFPA)
then
begin (*replace hard zero by const part*)
STK[TOP].FPA.MEMADR.DSPLMT := -CONSTPART;
CONSTPART := 0;
end;
FIT_IN_OPERAND (TOOMUCH1, OPND1, TOP-1);
FIT_IN_OPERAND (TOOMUCH2, OPND2, TOP);
if not TOOMUCH1 and not TOOMUCH2 then
CALCULABLE := true
else
begin (*must simplify*)
if not TOOMUCH1 then
begin
UNSIMPLE := TOP;
SIMPLER := TOP-1;
CONSTPART := -CONSTPART;
end
else if not TOOMUCH2 then
begin
UNSIMPLE := TOP-1;
SIMPLER := TOP;
end
else (*select one at random*)
begin
UNSIMPLE := TOP-1;
SIMPLER := TOP;
end;
if CONSTPART <> 0 then
if STK[UNSIMPLE].FINALIND = IND0 then
begin
if not (STK[UNSIMPLE].FPA.MEMADR.DSPLMT=0) then
ASSERTFAIL('PSBI 001');
STK[UNSIMPLE].FPA.MEMADR.DSPLMT:=CONSTPART
end
else
begin
if not ((STK[SIMPLER].FINALIND=IND0) and
(STK[SIMPLER].FPA.MEMADR.DSPLMT=0)) then
ASSERTFAIL('PSBI 002');
STK[SIMPLER].FPA.MEMADR.DSPLMT:=CONSTPART;
end;
SIMPLIFY (UNSIMPLE);
end (*must simplify*);
end (*not combinable*);
until COMBINABLE or CALCULABLE;
if COMBINABLE then
begin
STK[TOP-1].FPA.MEMADR.DSPLMT :=
STK[TOP-1].FPA.MEMADR.DSPLMT-STK[TOP].FPA.MEMADR.DSPLMT;
POPTOP;
STK[TOP].CODESTART := RESCODESTART;
end (*COMBINABLE*)
else
begin (*CALCULABLE*)
ADD_SUB_SINGLE (DEST, XSUB_S, OPND1, OPND2, TOP-1);
FREEREGSBUTONE (TOP, DEST);
POPTOP;
FREEREGSBUTONE (TOP, DEST);
REG_DATUM (TOP, RESCODESTART, TYPI, DEST);
STK[TOP].FPA.MEMADR.DSPLMT := CONSTPART;
end (*CALCULABLE*);
end (*TYPI*);
end (*PSBI*);
end (*case OPC of*)
end (*CASE2*);
(** ASMNXTINST_CLASS: CASE3 **)
(**)
procedure CASE3;
begin
case OPC of
PMPI :
begin
COERCE_TWO_DATUMS (IS_INTEGER);
RESCODESTART := STK[TOP-1].CODESTART;
if STK[TOP].DTYPE = TYPD then
begin
GET_OPERAND (OPND1, TOP-1);
GET_OPERAND (OPND2, TOP);
ALLOC_AND_EMIT_TOP (DEST, XMULT_D, OPND1, OPND2,
true, true, true, TOP-1);
FREEREGSBUTONE (TOP, DEST);
POPTOP;
FREEREGSBUTONE (TOP, DEST);
REG_DATUM (TOP, RESCODESTART, TYPD, DEST);
end (*TYPD*)
else
begin (*TYPI*)
COMBINABLE := false;
CALCULABLE := false;
repeat
if IS_CONSTANT(TOP) then
begin
if IS_CONSTANT(TOP-1) then
COMBINABLE := true
else
begin
SHIFTDIST := POWER2(STK[TOP].FPA.MEMADR.DSPLMT);
with STK[TOP-1] do
if (SHIFTDIST>=0) and (FPA.MEMADR.LVL=0) and
(FINALIND = IND0) and
((NVPAS=0) or
((NVPAS=1) and
(VPA1.VSHIFT+SHIFTDIST <= SFLDMAX) ))
then
COMBINABLE := true;
end;
end (*constant top*)
else if IS_CONSTANT(TOP-1) then
begin
SHIFTDIST := POWER2(STK[TOP-1].FPA.MEMADR.DSPLMT);
with STK[TOP] do
if (SHIFTDIST>=0) and (FPA.MEMADR.LVL=0) and
(FINALIND = IND0) and
((NVPAS=0) or
((NVPAS=1) and
(VPA1.VSHIFT+SHIFTDIST <= SFLDMAX) )) then
COMBINABLE := true;
end (*constant second from top*);
if not COMBINABLE then
begin
if IS_CONSTANT(TOP-1) and IS_CONST_PLUS_OPND(TOP) then
begin (*const*uncomplicated*)
CONSTPART := STK[TOP].FPA.MEMADR.DSPLMT
* STK[TOP-1].FPA.MEMADR.DSPLMT;
STK[TOP].FPA.MEMADR.DSPLMT := 0;
IMM_OPERAND (OPND1, STK[TOP-1].FPA.MEMADR.DSPLMT);
FIT_IN_OPERAND (TOOMUCH2, OPND2, TOP);
if not (not TOOMUCH2) then ASSERTFAIL('PMPI 001');
CALCULABLE := true;
end (*const*uncomplicated*)
else
if IS_CONSTANT(TOP) and IS_CONST_PLUS_OPND(TOP-1) then
begin (*uncomplicated*const*)
CONSTPART := STK[TOP].FPA.MEMADR.DSPLMT
* STK[TOP-1].FPA.MEMADR.DSPLMT;
STK[TOP-1].FPA.MEMADR.DSPLMT := 0;
FIT_IN_OPERAND (TOOMUCH1, OPND1, TOP-1);
if not (not TOOMUCH1) then ASSERTFAIL('PMPI 002');
IMM_OPERAND (OPND2, STK[TOP].FPA.MEMADR.DSPLMT);
CALCULABLE := true;
end (*const*uncomplicated*)
else
begin (*general case*)
FIT_IN_OPERAND (TOOMUCH1, OPND1, TOP-1);
FIT_IN_OPERAND (TOOMUCH2, OPND2, TOP);
if not TOOMUCH1 and not TOOMUCH2 then
begin
CONSTPART := 0;
CALCULABLE := true;
end
else
begin (*must simplify*)
if not TOOMUCH1 then
SIMPLIFY (TOP)
else if not TOOMUCH2 then
SIMPLIFY (TOP-1)
else (*select one at random*)
SIMPLIFY (TOP);
end (*must simplify*);
end (*general case*);
end (*if not COMBINABLE*)
until COMBINABLE or CALCULABLE;
if CALCULABLE then
begin
MULT_SINGLE (DEST, OPND1, OPND2, TOP-1);
FREEREGSBUTONE (TOP, DEST);
POPTOP;
FREEREGSBUTONE (TOP, DEST);
REG_DATUM (TOP, RESCODESTART, TYPI, DEST);
STK[TOP].FPA.MEMADR.DSPLMT := CONSTPART;
end (*CALCULABLE*)
else
begin (*COMBINABLE*)
STK[TOP-1].FPA.MEMADR.DSPLMT :=
STK[TOP-1].FPA.MEMADR.DSPLMT*STK[TOP].FPA.MEMADR.DSPLMT;
if (STK[TOP-1].NVPAS=0) and (STK[TOP].NVPAS<>0) then
begin
STK[TOP-1].NVPAS := STK[TOP].NVPAS;
STK[TOP-1].VPA1 := STK[TOP].VPA1;
(*Multiplicands not combinable if 2 VPAs exist*)
end;
with STK[TOP-1] do
begin
if not (NVPAS <= 1) then ASSERTFAIL('PMPI 003');
if NVPAS = 1 then
VPA1.VSHIFT := VPA1.VSHIFT + SHIFTDIST;
CODESTART := RESCODESTART;
end;
POPTOP;
end (*COMBINABLE*);
end (*TYPI*)
end (*PMPI*);
PDVI, PMOD :
begin
COERCE_TWO_DATUMS(IS_INTEGER);
RESCODESTART := STK[TOP-1].CODESTART;
RESTYPE := STK[TOP-1].DTYPE;
RESDBL := IS_DOUBLE[RESTYPE];
if IS_CONSTANT(TOP-1) and IS_CONSTANT(TOP) then
begin
if not (RESTYPE = TYPI) then ASSERTFAIL('PDVI,PMOD001');
if STK[TOP].FPA.MEMADR.DSPLMT = 0 then
ERROR(WINTEGER_CONSTANT_DIV_MOD_BY_ZERO)
else if OPC = PDVI then
STK[TOP-1].FPA.MEMADR.DSPLMT:=STK[TOP-1].FPA.MEMADR.DSPLMT
div STK[TOP].FPA.MEMADR.DSPLMT
else if OPC = PMOD then
STK[TOP-1].FPA.MEMADR.DSPLMT:=STK[TOP-1].FPA.MEMADR.DSPLMT
mod STK[TOP].FPA.MEMADR.DSPLMT
else if not (false) then ASSERTFAIL('PDVI,PMOD002');
POPTOP
end
else (*not both constants*)
begin
if OPC = PDVI then
if RESDBL then S1OP := XQUO_D else S1OP := XQUO_S
else if OPC = PMOD then
if RESDBL then S1OP := XREM_D else S1OP := XREM_S
else if not (false) then ASSERTFAIL('PDVI,PMOD003');
GET_OPERAND(OPND1,TOP-1);
GET_OPERAND(OPND2,TOP);
ALLOC_AND_EMIT_TOP(DEST,S1OP,OPND1,OPND2,
RESDBL, RESDBL, RESDBL, TOP-1);
FREEREGSBUTONE(TOP,DEST); POPTOP; FREEREGSBUTONE(TOP,DEST);
REG_DATUM(TOP,RESCODESTART,RESTYPE,DEST)
end (*not both constants*)
end (*PDVI, PMOD*);
end (*case OPC of*)
end (*CASE3*);
(** ASMNXTINNT_CLASS: CASE4 CASE5 **)
(**)
procedure CASE4;
begin
case OPC of
PADR, PSBR, PMPR, PDVR :
begin
COERCE_TWO_DATUMS(IS_REAL);
RESCODESTART := STK[TOP-1].CODESTART;
RESTYPE := STK[TOP-1].DTYPE;
RESDBL := IS_DOUBLE[RESTYPE];
if IS_CONSTANT(TOP) and IS_CONSTANT(TOP-1) then
begin
if not (RESTYPE = TYPR) then ASSERTFAIL('PADR,PSBR001');
if OPC = PADR then
STK[TOP-1].RCNST := STK[TOP-1].RCNST + STK[TOP].RCNST
else if OPC = PSBR then
STK[TOP-1].RCNST := STK[TOP-1].RCNST - STK[TOP].RCNST
else if OPC = PMPR then
STK[TOP-1].RCNST := STK[TOP-1].RCNST * STK[TOP].RCNST
else
begin
if not (OPC = PDVR) then ASSERTFAIL('PADR,PSBR002');
if STK[TOP].RCNST = 0 then
ERROR(WREAL_CONSTANT_DIVISION_BY_ZERO)
else STK[TOP-1].RCNST := STK[TOP-1].RCNST / STK[TOP].RCNST
end;
POPTOP
end
else (*not both constants*)
begin
S1OP := REAL_ARITH_OP[S1SIZE[RESTYPE],OPC];
GET_OPERAND(OPND1,TOP-1);
GET_OPERAND(OPND2,TOP);
ALLOC_AND_EMIT_TOP(DEST, S1OP, OPND1, OPND2,
RESDBL, RESDBL, RESDBL, TOP-1);
FREEREGSBUTONE(TOP,DEST); POPTOP; FREEREGSBUTONE(TOP,DEST);
REG_DATUM(TOP,RESCODESTART,RESTYPE,DEST)
end (*not both constants*)
end (*PADR, PSBR, PMPR, PDVR*);
PEQU, PNEQ, PGEQ, PGRT, PLEQ, PLES :
begin
RESCODESTART := STK[TOP-1].CODESTART;
if TYP <> TYPM then
begin
RESTYPE := COMPARE_COERCE_TYPE
[STK[TOP-1].DTYPE, STK[TOP].DTYPE];
if RESTYPE = ILLCOMP then
ERROR (WCOMPARE_ILLEGAL)
else if RESTYPE <> TYP then
ERROR (WWRONG_COMPARE);
COERCE_DATUM (TOP-1, RESTYPE);
COERCE_DATUM (TOP, RESTYPE);
if (RESTYPE in [TYPA, TYPI]) and
(STK[TOP-1].FINALIND=IND0) and (STK[TOP].FINALIND=IND0) then
begin (*Bring constant parts to one side.*)
if not ((STK[TOP-1].FPA.WHICH = MEM) and
(STK[TOP].FPA.WHICH = MEM)) then
ASSERTFAIL('PEQU,PNEQ001');
STK[TOP].FPA.MEMADR.DSPLMT := STK[TOP].FPA.MEMADR.DSPLMT
- STK[TOP-1].FPA.MEMADR.DSPLMT;
STK[TOP-1].FPA.MEMADR.DSPLMT := 0;
end (*Bring constant parts to one side.*);
if RESTYPE = TYPB then
begin
if STK[TOP-1].BREPRES = BJUMP then
BJUMP_TO_BINTVAL (TOP-1);
if STK[TOP].BREPRES = BJUMP then
BJUMP_TO_BINTVAL (TOP);
(*Note : <=,>=,<,> could be optimized as and, or are.*)
end;
S1OP := COMPARE_OP[S1SIZE[RESTYPE], OPC];
GET_OPERAND (OPND1, TOP-1);
GET_OPERAND (OPND2, TOP);
LOADSTACKEXCEPT (TOP-1, TOP);
if not RISFREE[S1RTB] and (RTBUSER < TOP-1) then
MOVE_AND_FREE_RTB;
FREEDATUMREGS (TOP);
POPTOP;
FREEDATUMREGS (TOP);
end (*TYP <> TYPM*)
else
begin (*TYP = TYPM*)
if not(STK[TOP-1].DTYPE in [TYPA, TYPM]) or
not(STK[TOP].DTYPE in [TYPA, TYPM]) then
ERROR (WCOMPM_NEEDS_ADDR);
(* make sure the zero and CPLPL global are free (to prevent errors) *)
ALLOCGBL (S1GBLZ);
OP1GBL := S1GCPLPL;
ALLOCGBL (OP1GBL);
OP1GBL := succ(OP1GBL);
ALLOCGBL (OP1GBL);
OP1GBL := succ(OP1GBL);
ALLOCGBL (OP1GBL);
OP1GBL := succ(OP1GBL);
ALLOCGBL (OP1GBL);
OP1GBL := succ(OP1GBL);
ALLOCGBL (OP1GBL);
(* initialize the global zero *)
OP1GBL := S1GBLZ;
ADDR_OPERAND (OPND1, OP1GBL*WORDUNITS);
EMITXOP (XMOV_S_S, OPND1, ZERO_OP);
(* initialize the CPLPL block-descriptor *)
OP1GBL := S1GCPLPL;
ADDR_OPERAND (OPND1, OP1GBL*WORDUNITS);
IMM_OPERAND (OPND2, S1GBLZ*WORDUNITS);
EMITXOP (XMOV_S_S, OPND1, OPND2);
OP1GBL := succ(OP1GBL);
ADDR_OPERAND (OPND1, OP1GBL*WORDUNITS);
MOVE_QUANTITY (OPND1, TOP-1);
OP1GBL := succ(OP1GBL);
ADDR_OPERAND (OPND1, OP1GBL*WORDUNITS);
IMM_OPERAND (OPND2, I1);
EMITXOP (XMOV_S_S, OPND1, OPND2);
OP1GBL := succ(OP1GBL);
ADDR_OPERAND (OPND1, OP1GBL*WORDUNITS);
MOVE_QUANTITY (OPND1, TOP);
OP1GBL := succ(OP1GBL);
ADDR_OPERAND (OPND1, OP1GBL*WORDUNITS);
IMM_OPERAND (OPND2, I1);
EMITXOP (XMOV_S_S, OPND1, OPND2);
(* emit the BLKCMP and subsequent flag test *)
ADDR_OPERAND (OPND2, S1GCPLPL*WORDUNITS); (*LCW*)
FINDRG;
OP1RG := NXTRG;
REG_OPERAND (OPND1, OP1RG);
EMITXOP (BLKCMP_X_Q[OPC], OPND1, OPND2);
DEST := OP1RG;
LOADSTACKEXCEPT (TOP-1, TOP);
POPTOP;
REG_OPERAND (OPND1, DEST);
IMM_OPERAND (OPND2, S1TRUEFLAG);
S1OP := XSKP_EQL_S;
if not RISFREE[S1RTB] then MOVE_AND_FREE_RTB;
FREERG_S (DEST);
(* free the global zero and CPLPL global *)
FREEGBL_S (S1GBLZ);
OP1GBL := S1GCPLPL;
FREEGBL_S (OP1GBL);
OP1GBL := succ(OP1GBL);
FREEGBL_S (OP1GBL);
OP1GBL := succ(OP1GBL);
FREEGBL_S (OP1GBL);
OP1GBL := succ(OP1GBL);
FREEGBL_S (OP1GBL);
OP1GBL := succ(OP1GBL);
FREEGBL_S (OP1GBL);
end (*TYPM*);
SKIPLOC := NEWINSTREC;
EMITSOP (S1OP, 0, OPND1, OPND2, nil);
EMITJOP (XJMPA, 0, UNUSED_OP, ZERO_OP, nil);
FIXSOP (SKIPLOC, NEWINSTREC);
STK[TOP] := ZERODATUM;
with STK[TOP] do
begin
CODESTART := RESCODESTART;
DTYPE := TYPB;
NVPAS := 1; (*make it not look like a constant. Not needed?*)
FINDRG;
VPA1.VPA.WHICH := RGS;
VPA1.VPA.RGADR := NXTRG;
(*where it will go if it becomes bintval*)
BREPRES := BJUMP;
BTRUELIST := EMPTYJUMPLIST;
BFALSELIST := EMPTYJUMPLIST;
BJUMPON := false;
BFALLTHRUSKIPLOC := SKIPLOC;
end (*with STK[TOP] do*);
end (*PEQU,...,PLES*);
end (*case OPC of*)
end (*CASE4*);
procedure CASE5;
begin
case OPC of
PAND, PIOR :
begin
if (STK[TOP-1].DTYPE<>TYPB) or (STK[TOP].DTYPE<>TYPB) then
ERROR (WANDOR_NEEDS_BOOLEAN);
RESCODESTART := STK[TOP-1].CODESTART;
if (STK[TOP-1].BREPRES=BINTVAL) and (STK[TOP].BREPRES=BINTVAL)
then
begin
if OPC = PIOR then ONE_IF_OR := 1 else ONE_IF_OR := 0;
if IS_CONSTANT(TOP) then
begin
if STK[TOP].FPA.MEMADR.DSPLMT = ONE_IF_OR then
begin
(*'X or true' or 'X and false'*)
FREEDATUMREGS (TOP-1);
STK[TOP-1] := ZERODATUM;
with STK[TOP-1] do
begin
CODESTART := RESCODESTART;
DTYPE := TYPB;
BREPRES := BINTVAL;
FPA.MEMADR.DSPLMT := ONE_IF_OR;
end;
end
else
(*'X and true' or 'X or false'*);
FREEDATUMREGS (TOP);
POPTOP;
end (*constant top*)
else if IS_CONSTANT(TOP-1) then
begin
FREEDATUMREGS (TOP-1);
if STK[TOP-1].FPA.MEMADR.DSPLMT = ONE_IF_OR then
begin
(*'true or X' or 'false and X'*)
STK[TOP-1] := ZERODATUM;
with STK[TOP-1] do
begin
CODESTART := RESCODESTART;
DTYPE := TYPB;
BREPRES := BINTVAL;
FPA.MEMADR.DSPLMT := ONE_IF_OR;
end;
end
else
begin
(*'true and X' or 'false or X'*);
STK[TOP-1] := STK[TOP];
if RTBUSER = TOP then RTBUSER := TOP-1;
end;
POPTOP;
end (*constant second from top*)
else
begin (*non-constant bintvals*)
if OPC = PAND then S1OP := XAND_Q else S1OP := XOR_Q;
GET_OPERAND (OPND1, TOP-1);
GET_OPERAND (OPND2, TOP);
ALLOC_AND_EMIT_TOP (DEST, S1OP, OPND1, OPND2,
false, false, false, TOP-1);
FREEREGSBUTONE (TOP, DEST);
POPTOP;
FREEREGSBUTONE (TOP, DEST);
REG_DATUM (TOP, RESCODESTART, TYPB, DEST);
STK[TOP].BREPRES := BINTVAL;
end (*non-constant bintvals*);
end (*two bintvals*)
(*Could do bjump and true, etc here*)
else
begin (*make everything bjump*)
if STK[TOP-1].BREPRES = BINTVAL then
begin
GROUP1 := TOP; GROUP2 := TOP-1;
STK[GROUP2].CODESTART := NEWINSTREC;
(*Kluge GROUP2 CODESTART to point to beginning of code
to convert BINTVAL to BJUMP so that fixed up
GROUP1 jumps will jump forward to code fork. Note
that RESCODESTART is already set up properly.*)
BINTVAL_TO_BJUMP (GROUP2);
end
else
begin
GROUP1 := TOP-1; GROUP2 := TOP;
if STK[TOP].BREPRES = BINTVAL then
BINTVAL_TO_BJUMP (TOP);
end;
if OPC = PAND then
begin
if STK[GROUP1].BJUMPON then
begin
INVERT_SKIP (STK[GROUP1].BFALLTHRUSKIPLOC);
STK[GROUP1].BJUMPON := false;
end;
FALLTHRUJUMP :=
NEXT_INSTRUCTION(STK[GROUP1].BFALLTHRUSKIPLOC);
if not (AFTER_FAKEOPS(JUMPSKIPDEST(STK[GROUP1].BFALLTHRUSKIPLOC))
= AFTER_FAKEOPS(STK[GROUP2].CODESTART)) then
ASSERTFAIL('PAND 001');
PTR := STK[GROUP1].BTRUELIST.FIRST;
while PTR <> nil do
begin
NEXT := JUMPSKIPDEST(PTR);
FIXJOP (PTR, STK[GROUP2].CODESTART);
PTR := NEXT;
end;
ADD_JUMPLIST_PLUS_ONE
(STK[TOP-1].BFALSELIST,STK[TOP].BFALSELIST,FALLTHRUJUMP);
STK[TOP-1].BTRUELIST := STK[GROUP2].BTRUELIST;
STK[TOP-1].BFALLTHRUSKIPLOC:=STK[GROUP2].BFALLTHRUSKIPLOC ;
STK[TOP-1].BJUMPON := STK[GROUP2].BJUMPON;
end (*PAND*)
else
begin (*PIOR*)
if not STK[GROUP1].BJUMPON then
begin
INVERT_SKIP (STK[GROUP1].BFALLTHRUSKIPLOC);
STK[GROUP1].BJUMPON := true;
end;
FALLTHRUJUMP :=
NEXT_INSTRUCTION(STK[GROUP1].BFALLTHRUSKIPLOC);
if not (
AFTER_FAKEOPS(JUMPSKIPDEST(STK[GROUP1].BFALLTHRUSKIPLOC))
= AFTER_FAKEOPS(STK[GROUP2].CODESTART)) then
ASSERTFAIL('PIOR 001');
PTR := STK[GROUP1].BFALSELIST.FIRST;
while PTR <> nil do
begin
NEXT := JUMPSKIPDEST(PTR);
FIXJOP (PTR, STK[GROUP2].CODESTART);
PTR := NEXT;
end;
ADD_JUMPLIST_PLUS_ONE
(STK[TOP-1].BTRUELIST, STK[TOP].BTRUELIST, FALLTHRUJUMP);
STK[TOP-1].BFALSELIST := STK[GROUP2].BFALSELIST;
STK[TOP-1].BFALLTHRUSKIPLOC:=STK[GROUP2].BFALLTHRUSKIPLOC;
STK[TOP-1].BJUMPON := STK[GROUP2].BJUMPON;
end (*PIOR*);
FREEDATUMREGS (TOP);
POPTOP;
STK[TOP].CODESTART := RESCODESTART;
end (*make everything bjump*);
end (*PAND, PIOR*);
end (*case OPC of*);
end (*CASE5*);
(** ASMNXTINST_CLASS: CASE6 CASE7 **)
(**)
procedure CASE6;
begin
case OPC of
PDIF, PINT, PUNI :
begin
if (STK[TOP-1].DTYPE <> TYPS) or (STK[TOP].DTYPE <> TYPS) then
ERROR(WSET_OPERATION_ON_NONSET_TYPES)
else
if IS_CONSTANT(TOP-1) and IS_CONSTANT(TOP) then
begin
if OPC = PDIF then
STK[TOP-1].PCNST := STK[TOP-1].PCNST - STK[TOP].PCNST
else if OPC = PINT then
STK[TOP-1].PCNST := STK[TOP-1].PCNST * STK[TOP].PCNST
else if OPC = PUNI then
STK[TOP-1].PCNST := STK[TOP-1].PCNST + STK[TOP].PCNST
else if not (false) then ASSERTFAIL('PDIF,PINT001');
POPTOP
end
else (*not both constants*)
begin
if OPC = PDIF then S1OP := XAND_TC_D
else if OPC = PINT then S1OP := XAND_D
else if OPC = PUNI then S1OP := XOR_D
else if not (false) then ASSERTFAIL('PDIF,PINT002');
GET_OPERAND(OPND1,TOP-1);
GET_OPERAND(OPND2,TOP);
ALLOC_AND_EMIT_TOP(DEST, S1OP, OPND1, OPND2,
true, true, true, TOP-1);
FREEREGSBUTONE(TOP,DEST); POPTOP;FREEREGSBUTONE(TOP,DEST);
REG_DATUM(TOP,STK[TOP].CODESTART,TYPS,DEST)
end (*not both constants*)
end (*PDIF, PINT, PUNI*);
PSGS, PINN :
begin
if OPC = PSGS then STE := TOP else STE := TOP-1;
with STK[STE] do
begin
if not IS_INTEGER[DTYPE] and not (DTYPE in [TYPB,TYPC]) then
ERROR(WSGS_OR_INN_REQUIRES_INT_CHAR_OR_BOOLEAN);
if DTYPE in [TYPB,TYPC] then
begin
if (DTYPE = TYPB) and (BREPRES = BJUMP) then
BJUMP_TO_BINTVAL(STE);
DTYPE := TYPQ
end;
COERCE_DATUM(STE,TYPI);
if IS_CONSTANT(STE) then
begin
DTYPE := TYPS;
PCNST := [FPA.MEMADR.DSPLMT];
FPA.MEMADR.DSPLMT := 0
end
else
begin (*not constant*)
IMM_OPERAND(OPND1,1);
GET_OPERAND(OPND2,STE);
ALLOC_AND_EMIT_TOP(DEST, XSHF_LF_D, OPND1, OPND2,
true, true, false, STE);
FREEREGSBUTONE(STE,DEST);
REG_DATUM(STE,CODESTART,TYPS,DEST)
end (*not constant*)
end (*with STK[STE] do*);
if OPC = PINN then
begin
if STK[TOP].DTYPE <> TYPS then
ERROR(WINN_REQUIRES_SET_ON_TOP_OF_STACK);
if IS_CONSTANT(TOP-1) and IS_CONSTANT(TOP) then
begin
with STK[TOP-1] do
begin
DTYPE := TYPB;
BREPRES := BINTVAL;
FPA.MEMADR.DSPLMT :=
ord(STK[TOP-1].PCNST*STK[TOP].PCNST <> []);
PCNST := []
end;
POPTOP;
end
else
begin (*not constants*)
RESCODESTART := STK[TOP-1].CODESTART;
GET_OPERAND(OPND1,TOP-1);
GET_OPERAND(OPND2,TOP);
LOADSTACKEXCEPT(TOP-1, TOP);
if not RISFREE[S1RTB] and (RTBUSER < TOP-1) then
MOVE_AND_FREE_RTB;
FREEDATUMREGS(TOP);
POPTOP;
FREEDATUMREGS(TOP);
SKIPLOC := NEWINSTREC;
EMITSOP (XSKP_NON_D, 0, OPND1, OPND2, nil);
EMITJOP (XJMPA, 0, UNUSED_OP, ZERO_OP, nil);
FIXSOP (SKIPLOC, NEWINSTREC);
STK[TOP] := ZERODATUM;
with STK[TOP] do
begin
CODESTART := RESCODESTART;
DTYPE := TYPB;
BREPRES := BJUMP;
NVPAS := 1; (*to make it not look
like a constant. Not needed?*)
FINDRG;
VPA1.VPA.WHICH := RGS;
VPA1.VPA.RGADR := NXTRG;
(*where it will go if it becomes bintval*)
BTRUELIST := EMPTYJUMPLIST;
BFALSELIST := EMPTYJUMPLIST;
BJUMPON := true;
BFALLTHRUSKIPLOC := SKIPLOC;
end (*with STK[TOP] do*);
end (*not constants*);
end (*if OPC = PINN*);
end (*PSGS, PINN*);
PBGN : ASM := (I1=1);
end (*case OPC of*)
end (*CASE6*);
procedure CASE7;
begin
case OPC of
PLOC :
begin
CURPLOC := I1;
(*A 'LOC 0' precedes each procedure, at which time the code list
has not yet been initialized. Hence do not emit a PLOC fake
instruction in that case.*)
if I1 > 0 then
begin
if DEBUG then EMITFAKEINST (XPLOC, I1);
end;
end (*PLOC*);
PLAB :
begin
UPD_LBLTBL (LPTR, LABELNUMBER(NAM0), LCODEPTR);
with LPTR↑ do
begin
if DEFINED then ERROR (WMULT_DEFINED_LAB);
DEFINED := true;
CODEPTR := NEWINSTREC;
if JUMPTABLELABEL then JUMPTABLE_IN_PROGRESS := true;
PTR := JLIST.FIRST;
while PTR <> nil do
begin
NEXT := JUMPSKIPDEST(PTR);
FIXJOP (PTR, CODEPTR);
PTR := NEXT
end;
JLIST := EMPTYJUMPLIST;
end (*with LPTR↑ do*);
end (*PLAB*);
PMOV :
begin
(* LCW 2AUG78
The strategy for PMOV is to do a BLKMOV if the transfer length is long
enough to justify the BLKMOV overhead, else to do a series of MOVMQs,
starting with the longest available MOVMQ and proceeding to the short
MOVMQs if necessary.
This procedure ignores the problem associated with having overlapping
source and destination where the source address is less than the
destination address. In that case, SOPA may destroy the source during
the MOV. However, if the source and destination overlap completely,
then SOPA will not destroy the source. Note that PASCAL and PCode do
not explicitly define the semantics of MOV when the source and
destination incompletely overlap.
*)
if not (STK[TOP-1].DTYPE in [TYPA,TYPM]) or
not (STK[TOP].DTYPE in [TYPA,TYPM]) then
ERROR (WMOV_NEEDS_ADDRS);
if I1 >= BLKMOV_THRESH then
begin (*generate BLKMOV*)
(*make sure that the global zero and CPL are free (error if not)*)
ALLOCGBL (S1GBLZ);
ALLOCRG (S1RCPL);
ALLOCRG (succ(S1RCPL));
ALLOCRG (succ(succ(S1RCPL)));
(* initialize the global zero *)
OP1GBL := S1GBLZ;
ADDR_OPERAND (OPND1, OP1GBL*WORDUNITS);
EMITXOP (XMOV_S_S, OPND1, ZERO_OP);
(*initialize the CPL block descriptor*)
REG_OPERAND (OPNDR1, S1RCPL);
IMM_OPERAND (OPND2, S1GBLZ*WORDUNITS);
EMITXOP (XMOV_S_S, OPNDR1, OPND2);
REG_OPERAND (OPNDR1, succ(S1RCPL));
MOVE_QUANTITY (OPNDR1, TOP-1);
REG_OPERAND (OPNDR1, succ(succ(S1RCPL)));
IMM_OPERAND (OPND2, I1);
EMITXOP (XMOV_S_S, OPNDR1, OPND2);
(*emit the BLKMOV*)
REG_OPERAND (OPNDR1, S1RCPL);
GET_ADDRESS (OPND2, TOP);
EMITXOP (XBLKMOV, OPNDR1, OPND2);
(*free the global zero and CPL registers*)
FREEGBL_S (S1GBLZ);
FREERG_S (S1RCPL);
FREERG_S (succ(S1RCPL));
FREERG_S (succ(succ(S1RCPL)));
end (*generate BLKMOV*)
else
begin (*generate MOVMQ*)
XFER_CNT := I1;
while XFER_CNT >= 128 do
begin
GET_ADDRESS (OPND1, TOP-1);
GET_ADDRESS (OPND2, TOP);
EMITXOP (XMOVMQ_128, OPND1, OPND2);
XFER_CNT := XFER_CNT - 128;
if XFER_CNT > 0 then
begin
INCREMENT_DATUM (TOP-1, 128);
INCREMENT_DATUM (TOP, 128);
end;
end;
if XFER_CNT >= 64 then
begin
GET_ADDRESS (OPND1, TOP-1);
GET_ADDRESS (OPND2, TOP);
EMITXOP (XMOVMQ_64, OPND1, OPND2);
XFER_CNT := XFER_CNT - 64;
if XFER_CNT > 0 then
begin
INCREMENT_DATUM (TOP-1, 64);
INCREMENT_DATUM (TOP, 64);
end;
end;
if XFER_CNT >= 32 then
begin
GET_ADDRESS (OPND1, TOP-1);
GET_ADDRESS (OPND2, TOP);
EMITXOP (XMOVMQ_32, OPND1, OPND2);
XFER_CNT := XFER_CNT - 32;
if XFER_CNT > 0 then
begin
INCREMENT_DATUM (TOP-1, 32);
INCREMENT_DATUM (TOP, 32);
end;
end;
if XFER_CNT > 0 then
begin
GET_ADDRESS (OPND1, TOP-1);
GET_ADDRESS (OPND2, TOP);
EMITXOP (MOVMQ_N[XFER_CNT], OPND1, OPND2);
end;
end (*generate MOVMQ*);
FREEDATUMREGS (TOP);
POPTOP;
FREEDATUMREGS (TOP);
POPTOP;
end (*PMOV*);
PIXA :
begin
if not (STK[TOP-1].DTYPE in [TYPA, TYPM]) then
ERROR (WIXA_NEEDS_ADDR);
with STK[TOP] do
if DTYPE in [TYPB, TYPC] then
begin
if (DTYPE=TYPB) and (BREPRES=BJUMP) then
BJUMP_TO_BINTVAL (TOP);
DTYPE := TYPQ;
end;
COERCE_DATUM (TOP, TYPI);
(*Multiply top of stack by I1.*)
with STK[TOP] do
if I1 <> 1 then
begin
COMBINABLE := false;
CALCULABLE := false;
SHIFTDIST := POWER2(I1);
RESCODESTART := CODESTART;
repeat
if (SHIFTDIST>=0) and (FPA.MEMADR.LVL=0) and
(FINALIND = IND0) and
((NVPAS=0) or
((NVPAS=1) and (VPA1.VSHIFT+SHIFTDIST<=SFLDMAX)))
or
IS_CONSTANT(TOP)
then
COMBINABLE := true
else if IS_CONST_PLUS_OPND(TOP) then
begin (*index is uncomplicated*)
CONSTPART := FPA.MEMADR.DSPLMT * I1;
FPA.MEMADR.DSPLMT := 0;
IMM_OPERAND (OPND1, I1);
FIT_IN_OPERAND (TOOMUCH2, OPND2, TOP);
if not (not TOOMUCH2) then ASSERTFAIL('PMPI 001');
CALCULABLE := true
end (*index is uncomplicated*)
else
begin (*general case*)
FIT_IN_OPERAND (TOOMUCH2, OPND2, TOP);
if TOOMUCH2 then
SIMPLIFY (TOP)
else
begin
CONSTPART := 0;
IMM_OPERAND (OPND1, I1);
CALCULABLE := true;
end;
end (*general case*)
until COMBINABLE or CALCULABLE;
if CALCULABLE then
begin
MULT_SINGLE (DEST, OPND1, OPND2, TOP);
FREEREGSBUTONE (TOP, DEST);
REG_DATUM (TOP, RESCODESTART, TYPI, DEST);
FPA.MEMADR.DSPLMT := CONSTPART;
end (*CALCULABLE*)
else
begin (*COMBINABLE*)
FPA.MEMADR.DSPLMT := FPA.MEMADR.DSPLMT * I1;
if not ((NVPAS<=1) or (I1=1)) then ASSERTFAIL('PIXA 002');
if NVPAS = 1 then
VPA1.VSHIFT := VPA1.VSHIFT + SHIFTDIST;
CODESTART := RESCODESTART
end (*COMBINABLE*);
end (*with STK[TOP] do*);
(*Simplify datums until combinable. We cannot emit an add
to combine them since the result must be
an address, with its high order bits zero.*)
if IS_CONSTANT(TOP) and
(STK[TOP].FPA.MEMADR.DSPLMT = 0) then
(*index is zero so just discard it*)
else
begin (*non-zero index*)
while STK[TOP].FINALIND > IND0 do
SIMPLIFY (TOP);
while STK[TOP-1].FINALIND > IND0 do
SIMPLIFY (TOP-1);
if STK[TOP-1].NVPAS > 0 then
while STK[TOP].NVPAS > 1 do
SIMPLIFY (TOP);
if STK[TOP].NVPAS > 0 then
while STK[TOP-1].NVPAS > 1 do
SIMPLIFY (TOP-1);
if not ((STK[TOP].FINALIND = IND0) and
(STK[TOP-1].FINALIND = IND0) and
(STK[TOP].FPA.MEMADR.LVL = 0) and
(STK[TOP].NVPAS + STK[TOP-1].NVPAS <= 2) ) then
ASSERTFAIL('PIXA 003');
STK[TOP-1].FPA.MEMADR.DSPLMT :=
STK[TOP-1].FPA.MEMADR.DSPLMT
+ STK[TOP].FPA.MEMADR.DSPLMT;
if STK[TOP-1].NVPAS = 0 then
case STK[TOP].NVPAS of
0 : (*null case*);
1 : STK[TOP-1].VPA1 := STK[TOP].VPA1;
2 : begin
STK[TOP-1].VPA1 := STK[TOP].VPA1;
STK[TOP-1].VPA2 := STK[TOP].VPA2;
end
end (*case*)
else if STK[TOP-1].NVPAS = 1 then
begin
if STK[TOP].NVPAS = 1 then
STK[TOP-1].VPA2 := STK[TOP].VPA1
end;
STK[TOP-1].NVPAS :=
STK[TOP-1].NVPAS + STK[TOP].NVPAS;
end (*non-zero index*);
if RTBUSER = TOP then RTBUSER := TOP - 1;
POPTOP;
end (*PIXA*);
end (*case OPC of*)
end (*CASE7*);
(** ASMNXTINST_CLASS: CASE8 **)
(**)
procedure CASE8;
begin
case OPC of
PDEF :
begin
UPD_LBLTBL (LPTR, LABELNUMBER(NAM0), LINTVAL);
with LPTR↑ do
begin
if DEFINED then ERROR (WMULT_DEFINED_LAB);
DEFINED := true;
INTVAL := I1;
PTR := CLIST.FIRST;
while PTR <> nil do
begin
FIXOPND2 (PTR↑.CODEPTR, INTVAL);
PTR := PTR↑.NEXTPTR;
end;
CLIST := EMPTYCODELIST;
end (*with LPTR↑ do*);
end (*PDEF*);
PSST :
begin
if I1 <= 0 then
ERROR (WINVALID_LEVEL);
if I1 > MAXLVLUSED then
begin
MAXLVLUSED := I1;
MINDSPS1REG := MAXDSPS1REG - (MAXLVLUSED-1);
CHECK_DSP_TMP_COLLISION
end;
with NESTDISPLAY[I1 (*level*)] do
begin
PROCTYPE := TYP;
PROCNAM := NAM1;
FIRSTPARMAREA := I2;
SECONDPARMAREA := I3;
VARAREA := I4;
REGPARMAREA := I5;
if REGPARMAREA > MAXPAREG * WORDUNITS then
ERROR (WLAST_SST_PARM_TOO_BIG);
if I1 = 1 then
begin
LCBEFPAR := LASTFILBUF;
OFFSET_IN_VARS := L1LOCALDATATRANSLATION
- LASTFILBUF;
end
else
begin
LCBEFPAR := LCAFTMST;
OFFSET_IN_VARS :=
MAX( -(MINSHORTOFFSET*WORDUNITS
+ LCBEFPAR - DOUBLEWORDUNITS
+ FUNCUNITS[PROCTYPE] + FIRSTPARMAREA
+ SECONDPARMAREA) ,
MIN(-MINSHORTOFFSET*WORDUNITS ,
VARAREA +TMPDATAWORDSGUESS*WORDUNITS
- MAXSHORTOFFSET*WORDUNITS));
end;
(*OFFSET_IN_VARS is the offset from the beginning of the
stack area in which local variables are stored to the
actual address stored in the display register for that
block. Its value is determined to try to maximize the
chance that references using that display register
(usually to local variables) will fit in short
operands. 'Normally,' the display register will point
-MINSHORTOFFSET words past the beginning of the local
variable area, to allow short addressing of the first
-MINSHORTOFFSET+MAXSHORTOFFSET words of the local
variables. (This is the first argument to 'MIN'
above.) However, if the local variable is small, there
is no point in being able to short address forward from
the display register to more than the 'usual' number of
temporary words, given by TMPDATAWORDSGUESS. (This is
the second argument to 'MIN' above.) On the third
hand, there is no point in being able to short address
backward from the display to locations in the eval save
area or before. (This is the first argument to 'MAX'
above.)
However, so that the support package knows where the
address is (P-Code location LCIOFILADR) we must make the
offset the same for every main program - i.e. for every
level-one procedure. (This is the purpose of the
if-statement above.) *)
LOCALDATAOFFSET := LCBEFPAR - DOUBLEWORDUNITS
+ FUNCUNITS[PROCTYPE]
+ FIRSTPARMAREA + SECONDPARMAREA
+ OFFSET_IN_VARS;
LOCALDATATRANSLATION := LCBEFPAR + FIRSTPARMAREA
+ SECONDPARMAREA + OFFSET_IN_VARS;
end (*with NESTDISPLAY[I1] do*);
if TR_NEST then
PRINT_NESTITEM (I1);
end (*PSST*);
PSTP :
begin
GEN_SEGMENT
end (*PSTP*);
PTON :
begin
if NAM1.NAM = 'PCODE ' then
TR_PCODE := true
else if NAM1.NAM = 'S1CODE ' then
begin
if NAM2.NAM[1] = 'P' then TR_S1CODE := true
else
begin
IPTR := MAINCODE.FIRST;
S1PC := SEG_EP_RELPC;
while IPTR <> nil do
begin
DISASSEMBLE (S1PC, IPTR);
IPTR := NEXT_INSTRUCTION (IPTR);
end;
end;
end
else if NAM1.NAM = 'STACK ' then
begin
if NAM2.NAM[1] = 'P' then TR_STACK := true
else PRINTDATUM (I1)
end
else if NAM1.NAM = 'MST ' then
begin
if NAM2.NAM[1] = 'P' then TR_MST := true
else PRINT_MSTENTRY (I1)
end
else if NAM1.NAM = 'NEST ' then
begin
if NAM2.NAM[1] = 'P' then TR_NEST := true
else PRINT_NESTITEM (I1)
end
else if NAM1.NAM = 'SIMP ' then
begin
if NAM2.NAM[1] = 'P' then TR_SIMP := true
else SIMPLIFY (I1)
end
else ERROR (WINVAL_TRACE);
end (*PTON*);
PTOF :
begin
if NAM1.NAM = 'S1CODE ' then
TR_S1CODE := false
else if NAM1.NAM = 'PCODE ' then
TR_PCODE := false
else if NAM1.NAM = 'STACK ' then
TR_STACK := false
else if NAM1.NAM = 'MST ' then
TR_MST := false
else if NAM1.NAM = 'NEST ' then
TR_NEST := false
else if NAM1.NAM = 'SIMP ' then
TR_SIMP := false
else
ERROR (WINVAL_TRACE);
end (*PTOF*);
PCHK :
with STK[TOP] do
begin
if not ((DTYPE in [TYPA,TYPB,TYPC,TYPN])
or IS_INTEGER[DTYPE]) then
ERROR(WCHECKING_INVALID_TYPE);
if DTYPE = TYPN then
if I1 < 0 then (*nil OK*)
else ERROR(WCHECKED_CONSTANT_OUT_OF_RANGE)
else if IS_CONSTANT(TOP) then
begin
if (FPA.MEMADR.DSPLMT < I1) or (FPA.MEMADR.DSPLMT > I2)
then
ERROR(WCHECKED_CONSTANT_OUT_OF_RANGE)
end
else
begin (*not constant*)
GET_OPERAND(OPND2,TOP);
if TYP = TYPA then
begin (*Make sure address is on heap (or maybe nil)*)
if DTYPE <> TYPA then
ERROR(WADDRESS_CHECK_ON_NONADDRESS);
"Comment out... (*BNDTRPKLU*)
if I1 < 0 then
begin
SKIPLOC := NEWINSTREC;
IMM_OPERAND(OPND1,NILVAL);
EMITSOP(XSKP_EQL_S,0,OPND1,OPND2,nil)
end;
REG_OPERAND(OPNDR,S1RNP);
EMITXOP(XBTRP_B_S,OPNDR,OPND2);
if I1 < 0 then
FIXSOP(SKIPLOC,NEWINSTREC)
...end of comment out" (*BNDTRPKLU*)
if I1 < 0 then (*BNDTRPKLU*)
begin (*BNDTRPKLU*)
SKIPLOC := NEWINSTREC; (*BNDTRPKLU*)
IMM_OPERAND(OPND1,NILVAL); (*BNDTRPKLU*)
EMITSOP(XSKP_NEQ_S,0,OPND1,OPND2,nil); (*BNDTRPKLU*)
JUMPLOC := NEWINSTREC; (*BNDTRPKLU*)
EMITJOP(XJMPA, 0, UNUSED_OP, ZERO_OP, nil);(*BNDTRPKLU*)
FIXSOP(SKIPLOC,NEWINSTREC) (*BNDTRPKLU*)
end; (*BNDTRPKLU*)
ADDR_OPERAND (OPND1, S1RNPMEMADR); (*BNDTRPKLU*)
SKIP1LOC := NEWINSTREC; (*BNDTRPKLU*)
EMITSOP (XSKP_LSS_S, 0, OPND2, OPND1, nil); (*BNDTRPKLU*)
ADDR_OPERAND (OPND1, S1RNPMEMADR+WORDUNITS); (*BNDTRPKLU*)
SKIP2LOC := NEWINSTREC; (*BNDTRPKLU*)
EMITSOP (XSKP_LEQ_S, 0, OPND2, OPND1, nil); (*BNDTRPKLU*)
FIXSOP (SKIP1LOC, NEWINSTREC); (*BNDTRPKLU*)
EMITJOP (XHALT, 0, UNUSED_OP, ZERO_OP, (*BNDTRPKLU*)
NEWINSTREC); (*BNDTRPKLU*)
FIXSOP (SKIP2LOC, NEWINSTREC); (*BNDTRPKLU*)
if I1 < 0 then (*BNDTRPKLU*)
FIXJOP(JUMPLOC,NEWINSTREC) (*BNDTRPKLU*)
end (*TYPA*)
else
begin (*not address check*)
"Comment out... (*BNDTRPKLU*)
if (TYP=TYPJ) and ((I1=0) or (I1=1)) then
begin
(*The error trap handler will deduce that the CHK
was TYPJ by the fact that the BTRP_N was used.*)
S1OP := BTRP_N_X[I1,DTYPE];
IMM_OPERAND(OPND1,I2)
end
else
begin
S1OP := BTRP_B_X[DTYPE];
EXTENDED_REGDISP_OPERAND(OPND1,S1RPC,0);
UPD_BOUNDTBL(OPND1.XW.DISP,I1,I2,TYP);
OPND1.FIXUP := BOUNDFIX
end;
EMITXOP(S1OP,OPND1,OPND2)
...end of comment out" (*BNDTRPKLU*)
IMM_OPERAND (OPND1, I1); (*BNDTRPKLU*)
SKIP1LOC := NEWINSTREC; (*BNDTRPKLU*)
EMITSOP (COMPARE_OP[S1SIZE[DTYPE],PLES], (*BNDTRPKLU*)
0, OPND2, OPND1, nil); (*BNDTRPKLU*)
IMM_OPERAND (OPND1, I2); (*BNDTRPKLU*)
SKIP2LOC := NEWINSTREC; (*BNDTRPKLU*)
EMITSOP (COMPARE_OP[S1SIZE[DTYPE],PLEQ], (*BNDTRPKLU*)
0, OPND2, OPND1, nil); (*BNDTRPKLU*)
FIXSOP (SKIP1LOC, NEWINSTREC); (*BNDTRPKLU*)
EMITJOP (XHALT, 0, UNUSED_OP, ZERO_OP, (*BNDTRPKLU*)
NEWINSTREC); (*BNDTRPKLU*)
FIXSOP (SKIP2LOC, NEWINSTREC); (*BNDTRPKLU*)
end (*not address check*)
end (*not constant*)
end (*PCHK*);
PUJP :
begin
if TOP <> BOT-1 then
ERROR (WUJP_WITH_NONEMPTY_STACK);
JUMPLOC := NEWINSTREC;
PR_BIT := ord( JUMPTABLE_IN_PROGRESS );
EMITJOP (XJMPA, PR_BIT, UNUSED_OP, ZERO_OP, nil);
JUMP_TO_LABEL_RECORD_OR_FIX (JUMPLOC, LABELNUMBER(NAM1));
end (*PUJP*);
PFJP :
begin
if TOP <> BOT then
ERROR (WFJP_WITH_NONEMPTY_STACK);
LABNUM := LABELNUMBER(NAM1);
with STK[TOP] do
begin
if DTYPE <> TYPB then
ERROR (WFJP_NEEDS_BOOLEAN);
if BREPRES = BINTVAL then
if IS_CONSTANT(TOP) then
if FPA.MEMADR.DSPLMT = 1 then
(*FJP, arg true, so no jump*)
else
begin (*FJP, arg false, so jump always*)
JUMPLOC := NEWINSTREC;
EMITJOP (XJMPA, 0, UNUSED_OP, ZERO_OP, nil);
JUMP_TO_LABEL_RECORD_OR_FIX (JUMPLOC, LABNUM);
end
else
begin (*non-constant bintval*)
GET_OPERAND (OPND1, TOP);
JUMPLOC := NEWINSTREC;
EMITJOP (XJMPZ_EQL_Q, 0, OPND1, ZERO_OP, nil);
JUMP_TO_LABEL_RECORD_OR_FIX (JUMPLOC, LABNUM);
end (*non-constant bintval*)
else
begin (*bjump representation*)
if BJUMPON then
begin
INVERT_SKIP (BFALLTHRUSKIPLOC);
BJUMPON := false;
end;
PTR := BTRUELIST.FIRST;
while PTR <> nil do
begin
NEXT := JUMPSKIPDEST(PTR);
FIXJOP (PTR, NEWINSTREC);
PTR := NEXT;
end;
PTR := BFALSELIST.FIRST;
while PTR <> nil do
begin
NEXT := JUMPSKIPDEST(PTR);
JUMP_TO_LABEL_RECORD_OR_FIX (PTR, LABNUM);
PTR := NEXT;
end;
FALLTHRUJUMP := NEXT_INSTRUCTION(BFALLTHRUSKIPLOC);
JUMP_TO_LABEL_RECORD_OR_FIX (FALLTHRUJUMP, LABNUM);
end (*bjump representation*);
end (*with STK[TOP] do*);
FREEDATUMREGS (TOP);
POPTOP;
end (*PFJP*);
PXJP :
begin
(*XJP compiles into
SKP if too small to A
SKP if not too big to B
A: JUMP to default
B: JUMP to wherever(index) *)
if TOP <> BOT then
ERROR (WXJP_WITHOUT_SINGLETON_STACK);
LABNUM := LABELNUMBER(NAM1);
COERCE_DATUM (TOP, TYPI);
if IS_CONSTANT(TOP) then
begin
IMM_OPERAND (OPND, STK[TOP].FPA.MEMADR.DSPLMT);
EXTENDED_REGDISP_OPERAND
(OPND1, S1RPC, - STK[TOP].FPA.MEMADR.DSPLMT)
(*Looks funny but it is compatible with
the negate-and-shift fixup which
must be done in the case of a
variable index.*)
end
else
begin
GET_SHORT_OPERAND (OPND, TOP);
OPND1 := OPND;
OPND1.X := 1;
OPND1.XW.V := 1;
OPND1.XW.S := DALIGNSHIFT;
OPND1.XW.REG := S1RPC;
OPND.XW.DISP := 0;
end;
SKIPSMALL := NEWINSTREC;
EMITSOP (XSKP_LSS_S, 0, OPND, EXTENDED_ZERO_OP, nil);
SKIPNOTBIG := NEWINSTREC;
EMITSOP (XSKP_LEQ_S, 0, OPND, EXTENDED_ZERO_OP, nil);
JUMPDEFAULT := NEWINSTREC;
EMITJOP (XJMPA, 0, UNUSED_OP, ZERO_OP, nil);
JUMPINDEXED := NEWINSTREC;
EMITJOP (XJMPA, 0, UNUSED_OP, OPND1, nil);
OPND2_RECORD_OR_FIX (SKIPSMALL, LABNUM);
FIXSOP (SKIPSMALL, JUMPDEFAULT);
OPND2_RECORD_OR_FIX (SKIPNOTBIG, LABNUM+1);
FIXSOP (SKIPNOTBIG, JUMPINDEXED);
JUMP_TO_LABEL_RECORD_OR_FIX (JUMPDEFAULT, LABNUM+3);
OPND2_RECORD_OR_FIX (JUMPINDEXED, LABNUM);
ADD_CODEPTR_TO_CODELIST (NEG_SHIFT_FIXLIST, JUMPINDEXED);
(*All OPND2s on this fixup list will have the displacement
in the extended word negated and arithmetically shifted
to make it a doubleword index.*)
JUMP_TO_TABLE_RECORD_OR_FIX (JUMPINDEXED, LABNUM+2);
FREEDATUMREGS (TOP);
POPTOP;
end (*PXJP*);
end (*case OPC of*)
end (*CASE8*);
(** ASMNXTINST_CLASS: CASE9 **)
(**)
procedure CASE9;
begin
case OPC of
PENT :
begin
if MAINCODE.NWORDS > 0 then GEN_SEGMENT;
CURPROCXN := NAM0;
CURLVL := I1;
LOCALSIZELNUM := LABELNUMBER(NAM1);
CURPROC := NAM2.NAM;
DEBUG := (I4=1);
INIT_SEGMENT;
with NESTDISPLAY[CURLVL] do
begin
if (PROCNAM<>NAM0) or (PROCTYPE<>TYP) then
ERROR (WSST_AND_ENT_INCONSISTENT);
DISPLAY := LVL_TO_S1REG[CURLVL];
if not (MINDSPS1REG <= DISPLAY) then ASSERTFAIL('PENT 001');
RESERVE_PARMREGS (REGPARMAREA div WORDUNITS);
FRAMESIZEPART := -DOUBLEWORDUNITS + FUNCUNITS[PROCTYPE]
(*+ Local size from label by fixup*)
(*+ Eval save size by fixup*);
if not DEBUG then
begin
REG_OPERAND (OPNDR, DISPLAY);
EXTENDED_REGDISP_OPERAND (OPND2, S1RSP,
LOCALDATAOFFSET
(*+ eval save size by fixup*) );
INSTLOC := NEWINSTREC;
EMITXOP (XMOV_A, OPNDR, OPND2);
ADD_CODEPTR_TO_CODELIST (EVALSAVE.FIXLIST, INSTLOC);
EXTENDED_IMM_OPERAND (OPND2, FRAMESIZEPART);
INSTLOC := NEWINSTREC;
EMITXOP (XADJSP_UP, OPNDRSP, OPND2);
OPND2_RECORD_OR_FIX (INSTLOC, LOCALSIZELNUM);
ADD_CODEPTR_TO_CODELIST (EVALSAVE.FIXLIST, INSTLOC);
end
else
begin (*allocate extra word for callee segment base save*)
REG_OPERAND (OPNDR, DISPLAY);
EXTENDED_REGDISP_OPERAND (OPND2, S1RSP,
LOCALDATAOFFSET + WORDUNITS
(*+ eval save size by fixup*) );
INSTLOC := NEWINSTREC;
EMITXOP (XMOV_A, OPNDR, OPND2);
ADD_CODEPTR_TO_CODELIST (EVALSAVE.FIXLIST, INSTLOC);
ADDR_OPERAND (OPND1, S1GSEGBASE*WORDUNITS);
EXTENDED_IMM_OPERAND (OPND2, FRAMESIZEPART+WORDUNITS);
INSTLOC := NEWINSTREC;
EMITXOP (XALLOC_1, OPND1, OPND2);
OPND2_RECORD_OR_FIX (INSTLOC, LOCALSIZELNUM);
ADD_CODEPTR_TO_CODELIST (EVALSAVE.FIXLIST, INSTLOC);
EXTENDED_REGDISP_OPERAND (OPND2, S1RPC, 0);
EMITXOP (XMOV_A, OPND1, OPND2);
(*OPND2 needs to be fixed up by subtracting this
instruction's displacement in the segment. The
code concretizer will do this automatically
because it normalizes *all* PC-relative addresses
to the beginning of the segment.*)
end (*allocate extra word*);
EXCESS := FIRSTPARMAREA - REGPARMAREA;
if EXCESS > 0 then
begin
(*There were so many parms that we passed some on top
of the stack rather than in regs. Copy them into the
parm save area where they belong.*)
(*Here we emit a BLKMOV to copy the parameters into their
new location. It would be better to use MOVMQ if possible,
but since fixup is required, the MOVMQ/BLKMOV generator seems
too much trouble to code for the negligible payoff. We
can improve this later after the S1 storage alloation is
changed. LCW*)
(*make sure that the global zero and CPL are free (error if not)*)
ALLOCGBL (S1GBLZ);
ALLOCRG (S1RCPL);
ALLOCRG (succ(S1RCPL));
ALLOCRG (succ(succ(S1RCPL)));
(* initialize the global zero *)
OP1GBL := S1GBLZ;
ADDR_OPERAND (OPND1, OP1GBL*WORDUNITS);
EMITXOP (XMOV_S_S, OPND1, ZERO_OP);
(*initialize the CPL block descriptor*)
REG_OPERAND (OPNDR1, S1RCPL);
IMM_OPERAND (OPND2, S1GBLZ*WORDUNITS);
EMITXOP (XMOV_S_S, OPNDR1, OPND2);
REG_OPERAND (OPNDR1, succ(S1RCPL));
REGDISP_OPERAND (OPND2, DISPLAY,
-(OFFSET_IN_VARS + SECONDPARMAREA + FIRSTPARMAREA)
+ REGPARMAREA);
EMITXOP (XMOV_A, OPNDR1, OPND2);
REG_OPERAND (OPNDR1, succ(succ(S1RCPL)));
IMM_OPERAND (OPND2, EXCESS);
EMITXOP (XMOV_S_S, OPNDR1, OPND2);
(*emit the BLKMOV*)
REG_OPERAND (OPNDR1, S1RCPL);
EXTENDED_REGDISP_OPERAND (OPND2, DISPLAY,
-LOCALDATAOFFSET + WORDUNITS
"*- Eval save size by fixup*" );
"*The caller did not know whether or not this
procedure required a segment base save,
so it left an unused word before the parms
just in case. The WORDUNITS is that word.*"
INSTLOC := NEWINSTREC;
EMITXOP (XBLKMOV, OPNDR1, OPND2);
ADD_CODEPTR_TO_CODELIST (EVALSAVE.NEGFIXLIST, INSTLOC);
(*free the global zero and CPL registers*)
FREEGBL_S (S1GBLZ);
FREERG_S (S1RCPL);
FREERG_S (succ(S1RCPL));
FREERG_S (succ(succ(S1RCPL)));
end (*if EXCESS > 0*);
end (*with NESTDISPLAY...*);
end (*PENT*);
PRET :
with NESTDISPLAY[CURLVL] do
begin
if PROCTYPE<>TYP then
ERROR (WSST_AND_RET_INCONSISTENT);
if TYP <> TYPP then
begin (*copy function result to RTB*)
REGDISP_OPERAND (OPND2, DISPLAY,
-LOCALDATAOFFSET + FNCRSLT );
EMITXOP (MOV_X_X[TYP], OPNDRTB, OPND2);
end (*copy function result*);
REG_OPERAND (OPNDR, DISPLAY);
if DEBUG then
begin
EXTENDED_REGDISP_OPERAND (OPND2, DISPLAY,
- WORDUNITS - LOCALDATAOFFSET
(*- Eval save size by fixup*) );
ADDR_OPERAND (OPND1, S1GSEGBASE*WORDUNITS);
INSTLOC := NEWINSTREC;
EMITXOP (XMOV_S_S, OPND1, OPND2);
ADD_CODEPTR_TO_CODELIST (EVALSAVE.NEGFIXLIST, INSTLOC);
EXTENDED_REGDISP_OPERAND (OPND2, DISPLAY,
- WORDUNITS - LOCALDATAOFFSET
(*- Eval save size by fixup*) ); (*LCW*)
INSTLOC := NEWINSTREC;
EMITXOP (XRETSR, OPNDR, OPND2);
ADD_CODEPTR_TO_CODELIST (EVALSAVE.NEGFIXLIST, INSTLOC);
end
else
begin
EXTENDED_REGDISP_OPERAND (OPND2, DISPLAY,
- LOCALDATAOFFSET
(*- Eval save size by fixup*) ); (*LCW*)
INSTLOC := NEWINSTREC;
EMITXOP (XRETSR, OPNDR, OPND2);
ADD_CODEPTR_TO_CODELIST (EVALSAVE.NEGFIXLIST, INSTLOC);
end;
end (*PRET*);
PMST :
begin
MSTTOP := MSTTOP + 1;
if MSTTOP > MAXMST then
ERROR (WFUNC_CALLS_NESTED_TOO_DEEPLY)
else
begin
with MSTSTK[MSTTOP] do
begin
DESTLEV := (*CURLVL + 1 -*) I1;
LASTEXPR := TOP;
CURPARMREGS := CURRENT_PARMREG_COUNT;
DESTFIRSTPARMAREA := I2;
DESTREGPARMAREA := I3;
MSTCODESTART := NEWINSTREC;
end (*with MSTSTK[MSTTOP]*);
DSPL := MSTSTK[MSTTOP-1].EVALSAVESTART;
for STE := MSTSTK[MSTTOP-1].LASTEXPR + 1 to TOP do
with STK[STE] do
if NVPAS>0 then
if (DTYPE=TYPB) and (BREPRES=BJUMP) then
begin (*Save BJUMP temp reg just in case used*)
DSPL := DSPL + WORDUNITS;
REGDISP_OPERAND(OPND1,DISPLAY,
-NESTDISPLAY[CURLVL].LOCALDATAOFFSET-DSPL);
REG_OPERAND(OPNDR,VPA1.VPA.RGADR);
EMITXOP(XMOV_S_S,OPND1,OPNDR)
end (*Save BJUMP temp reg*)
else
begin
(*This datum's value may be susceptible to
change by side effect. Get it into eval
save area to protect it.*)
if IS_DOUBLE[DTYPE] then
DSPL := DSPL + DOUBLEWORDUNITS
else DSPL := DSPL + WORDUNITS;
REGDISP_OPERAND (OPND1, DISPLAY,
-NESTDISPLAY[CURLVL].LOCALDATAOFFSET-DSPL);
MOVE_QUANTITY (OPND1, STE);
if not DATUM_IS_T_REG(STE)
and not DATUM_IS_FILADR(STE) then
begin (*arrange to restore it to a temp*)
if IS_DOUBLE[DTYPE] then FINDRP
else FINDRG;
REG_DATUM (STE, CODESTART, DTYPE, NXTRG);
end;
end (*get datum into eval save*);
FREE_TEMP_REGS;
with MSTSTK[MSTTOP] do
begin
PREGS := DESTREGPARMAREA div WORDUNITS;
if CURPARMREGS < PREGS then
RESERVE_PARMREGS (PREGS);
EVALSAVESTART := DSPL;
if DSPL > EVALSAVE.SIZE then EVALSAVE.SIZE := DSPL;
end;
end (*no error*);
end (*PMST*);
PCSP : CALLSTANDARD;
PPAR :
begin
COERCE_DATUM(TOP,TYP);
(*The following conversion would happen sooner or later anyway, PTZ
but it's now clear that it MUST happen, so do it. PTZ
This avoids a problem in PCUP where two MOVs are generated PTZ
instead of a SLR because the representation isn't right at the time PTZ*)
if STK[TOP].DTYPE = TYPB then (*PTZ*)
if STK[TOP].BREPRES = BJUMP then (*PTZ*)
BJUMP_TO_BINTVAL(TOP) (*PTZ*)
end (*PPAR*);
end (*case OPC of*)
end (*CASE9*);
(** ASMNXTINST_CLASS: CASE10 **)
(**)
procedure CASE10;
begin
case OPC of
PCUP :
begin
with MSTSTK[MSTTOP], NESTDISPLAY[CURLVL] do
begin
PARM := LASTEXPR + 1;
RESCODESTART := MSTCODESTART;
PWORD := 0;
LASTPREG := REGPARMAREA div WORDUNITS - 1;
DESTLASTPREG := DESTREGPARMAREA div WORDUNITS - 1;
if REGPARMAREA > 0 then
begin (*Caller parmregs must be archived.*)
(*Load new parmregs, archiving old ones.*)
while (PWORD<=LASTPREG) and (PWORD<=DESTLASTPREG)
and (PARM<=TOP) do
begin (*Load one parm, preserving old*)
with STK[PARM] do
begin
REGDISP_OPERAND (OPND1, LVL_TO_S1REG[CURLVL],
- OFFSET_IN_VARS - SECONDPARMAREA - FIRSTPARMAREA
+ PWORD*WORDUNITS);
PARMREG_TO_PARMSAVE (PARM, PWORD);
if (IS_SINGLE[DTYPE] or
DATUM_IS_REG(PARM) and not IS_DOUBLE[DTYPE])
then
SLR_QUANTITY (OPND1, PRM_TO_S1REG[PWORD], PARM)
else
begin (*SLR not applicable; use two MOVs*)
REG_OPERAND (OPNDR, PRM_TO_S1REG [PWORD]);
if IS_DOUBLE[DTYPE] and not (PWORD=LASTPREG)
then MOVEOP := XMOV_D_D
else MOVEOP := XMOV_S_S;
EMITXOP (MOVEOP, OPND1, OPNDR);
MOVE_QUANTITY (OPNDR, PARM);
end (*SLR not applicable*);
FREEDATUMREGS (PARM);
if IS_DOUBLE[DTYPE] then PWORD := PWORD + 2
else PWORD := PWORD + 1;
end (*with STK[PARM]*);
PARM := PARM + 1;
end (*while*);
(*if any caller parmregs remain unarchived, archive them.*)
(* Changed to use MOVMS_N 5 dec 78 ALS *)
PREG := PWORD;
if PREG <= LASTPREG then
begin
REGDISP_OPERAND (OPND1, LVL_TO_S1REG[CURLVL],
- OFFSET_IN_VARS - SECONDPARMAREA - FIRSTPARMAREA
+ PREG*WORDUNITS);
REG_OPERAND (OPNDR, PRM_TO_S1REG [PREG]);
MOVENUM := MIN (MAXMOVMS, (LASTPREG-PREG+1));
EMITXOP (MOVMS_N[MOVENUM], OPND1, OPNDR);
PREG := PREG + MOVENUM;
end;
end (*Caller parmregs must be archived*);
(*Go on loading new parmregs.*)
while (PWORD<=DESTLASTPREG) and (PARM<=TOP) do
begin
REG_OPERAND (OPNDR, PRM_TO_S1REG [PWORD]);
PARMREG_TO_PARMSAVE (PARM, PWORD);
MOVE_QUANTITY (OPNDR, PARM);
if IS_DOUBLE[STK[PARM].DTYPE] then PWORD := PWORD + 2
else PWORD := PWORD + 1;
FREEDATUMREGS (PARM);
PARM := PARM + 1;
end;
if PWORD > DESTLASTPREG+1 then
ERROR (WREGPARMS_SPEC_TOO_LOW_IN_MST);
(*Move remaining parms (if any) to stack top.*)
if PARM <= TOP then
begin
SP_TWIDDLE := DESTFIRSTPARMAREA - DESTREGPARMAREA
+ 2*WORDUNITS (*disp&PC save space*)
+ WORDUNITS;
(*WORDUNITS allows for a callee seg base save.*)
IMM_OPERAND (OPND2, SP_TWIDDLE);
EMITXOP (XADJSP_UP, OPNDRSP, OPND2);
DSPL := -DESTFIRSTPARMAREA + PWORD*WORDUNITS;
while PARM <= TOP do
begin
PARMREG_TO_PARMSAVE (PARM, PWORD);
REGDISP_OPERAND (OPND1, S1RSP, DSPL);
MOVE_QUANTITY (OPND1, PARM);
FREEDATUMREGS (PARM);
if IS_DOUBLE[STK[PARM].DTYPE] then
begin PWORD := PWORD + 2;
DSPL := DSPL + DOUBLEWORDUNITS;
end
else
begin PWORD := PWORD + 1;
DSPL := DSPL + WORDUNITS;
end;
PARM := PARM + 1;
end;
IMM_OPERAND (OPND2, SP_TWIDDLE);
EMITTOP (XSUB_S, 0, OPNDRSP, OPND2);
end (*Move remaining parms to stack top*);
while TOP > LASTEXPR do POPTOP; (*optimizable*)
if PWORD <> DESTFIRSTPARMAREA div WORDUNITS then
if PWORD < DESTFIRSTPARMAREA div WORDUNITS then
ERROR (WINSUFF_PARMS_SPECIFIED)
else
ERROR (WMST_SPECIFIED_INSUFF_PARM_STORAGE);
REG_OPERAND (OPNDR, LVL_TO_S1REG[DESTLEV]);
EXT_REGADDR_OPERAND (OPND2, S1RPC, SEG_EP_RELPC); (*EJG*)
OPND2.FIXUP := XTRNSYMFIX;
UPD_PROCTBL (OPND2.FIXPTR, NAM1.NAM);
EMITJOP (XJSR, 0, OPNDR, OPND2, nil);
RESERVE_PARMREGS (CURPARMREGS);
end (*with MSTSTK, NESTDISPLAY*);
with MSTSTK[MSTTOP-1], NESTDISPLAY[CURLVL] do
begin (*Restore expr stack and parmregs.*)
DSPL := EVALSAVESTART;
RTBSAVED := false;
for STE := LASTEXPR + 1 to TOP do
with STK[STE] do
if NVPAS>0 then
if (DTYPE=TYPB) and (BREPRES=BJUMP) then
begin (*Restore BJUMP temp reg*)
REG_OPERAND(OPNDR,VPA1.VPA.RGADR);
DSPL := DSPL + WORDUNITS;
ALLOCRG(VPA1.VPA.RGADR);
REGDISP_OPERAND(OPND2,DISPLAY,
-LOCALDATAOFFSET - DSPL);
EMITXOP(XMOV_S_S,OPNDR,OPND2)
end (*Restore BJUMP temp reg*)
else
begin (*Restore one expr temp.*)
if not (DATUM_IS_T_REG(STE) or DATUM_IS_FILADR(STE) ) then
ASSERTFAIL('PCUP 001');
FIT_IN_OPERAND (TOOMUCH1, OPND1, STE);
if not ( not TOOMUCH1) then ASSERTFAIL('PCUP 002');
if IS_DOUBLE[DTYPE] then DSPL := DSPL+2*WORDUNITS
else DSPL := DSPL + WORDUNITS;
if (TYP<>TYPP) and IS_RTB(OPND1) then
begin
(*We will be getting a function value back in
RTB, so remember to restore the thing
which was there into another temporary,
after restoring all the others so we know
which ones are available.*)
RTBSAVED := true;
RTBDATUM := STE;
RTBDSPL := DSPL;
end (*RTB*)
else
begin (*ordinary temporary*)
if DATUM_IS_T_REG(STE) then
if IS_DOUBLE[DTYPE] then
ALLOCRP(VPA1.VPA.RGADR)
else ALLOCRG(VPA1.VPA.RGADR);
REGDISP_OPERAND (OPND2, DISPLAY,
-LOCALDATAOFFSET - DSPL);
EMITXOP (MOV_X_X[DTYPE], OPND1, OPND2);
end (*ordinary temp reg*);
end (*restore one expr temp*);
if RTBSAVED then
with STK[RTBDATUM] do
begin (*Restore it somewhere else*)
if IS_DOUBLE[DTYPE] then
begin FINDRP; S1OP := XMOV_D_D; end
else
begin FINDRG; S1OP := XMOV_S_S; end;
VPA1.VPA.RGADR := NXTRG;
REG_OPERAND (OPNDR, NXTRG);
REGDISP_OPERAND (OPND2, DISPLAY,
-LOCALDATAOFFSET - RTBDSPL);
EMITXOP (S1OP, OPNDR, OPND2);
end (*if RTBSAVED*);
RESTORE_PARMREGS;
end (*Restore expr stack and parmregs.*);
if TYP <> TYPP then
begin (*Function value being returned in RTB.*)
PUSHTOP;
if IS_DOUBLE[TYP] then ALLOCRP (S1RTB) else ALLOCRG (S1RTB);
REG_DATUM (TOP, RESCODESTART, TYP, S1RTB);
RTBUSER := TOP;
RTBDOUB := IS_DOUBLE[TYP];
end (*function value being returned*);
MSTTOP := MSTTOP - 1;
end (*PCUP*)
end (*case OPC of*)
end (*CASE10*);
(** ASMNXTINST_CLASS: **)
(**)
begin (*ASMNXTINST*)
if JUMPTABLE_IN_PROGRESS then
if ord(OPC) <= MAXSETEL then
JUMPTABLE_IN_PROGRESS :=
(OPC in [PUJP, PLAB, PDEF, PLOC, PSST, PBGN])
else
JUMPTABLE_IN_PROGRESS := false;
(*Some operations are available as both instructions and
as standard procedures. Translate such into either one or the
other to avoid duplication of effort.*)
if ord(OPC) <= MAXSETEL then
if OPC in [PEOF, PNEW, PSAV, PRST] then
begin
NAM1.LEN := 3;
if OPC = PEOF then NAM1.NAM := 'EOF '
else if OPC = PSAV then NAM1.NAM := 'SAV '
else if OPC = PRST then NAM1.NAM := 'RST '
else if OPC = PNEW then
begin
NAM1.NAM := 'NEW ';
PUSHTOP;
STK[TOP] := ZERODATUM;
with STK[TOP] do
begin
CODESTART := NEWINSTREC;
DTYPE := TYPI;
FPA.MEMADR.DSPLMT := I1;
end;
end (*new*)
else if not (false) then ASSERTFAIL('ASMNXTINS001');
OPC := PCSP;
end (*if OPC in...*);
case OPC of
PABI, PABR, PNGI, PNGR, PSQI,
PSQR, PINC, PDEC, PPRE, PSUC,
PORD, PCHR, PFLO, PFLT, PTRC :
CASE1;
PODD, PNOT, PADI, PSBI :
CASE2;
PMPI, PDVI, PMOD :
CASE3;
PADR, PSBR, PMPR, PDVR, PEQU,
PNEQ, PGEQ, PGRT, PLEQ, PLES :
CASE4;
PAND, PIOR :
CASE5;
PDIF, PINT, PUNI, PSGS, PINN,
PBGN :
CASE6;
PLOC, PLAB, PMOV, PIXA :
CASE7;
PDEF, PSST, PSTP, PTOF, PTON,
PCHK, PUJP, PFJP, PXJP :
CASE8;
PENT, PRET, PMST, PCSP, PPAR :
CASE9;
PCUP :
CASE10;
PLDC :
begin
PUSHTOP; STK[TOP] := ZERODATUM;
with STK[TOP] do
begin
CODESTART := NEWINSTREC;
DTYPE := TYP;
case TYP of
TYPI, TYPC :
begin
FPA.WHICH := MEM;
FPA.MEMADR.LVL := 0;
FPA.MEMADR.DSPLMT := I1;
end;
TYPB :
begin
FPA.WHICH := MEM;
FPA.MEMADR.LVL := 0;
FPA.MEMADR.DSPLMT := I1;
BREPRES := BINTVAL;
end;
TYPR : RCNST := R1;
TYPN : (*null case*);
TYPS : PCNST := P1;
TYPA, TYPD, TYPH, TYPJ, TYPM, TYPP, TYPQ, TYPX :
ERROR (WINVAL_TYP_ON_LDC)
end (*case TYP of*);
end (*with STK[TOP] do*);
end (*LDC*);
PLCA :
begin
PUSHTOP; STK[TOP] := ZERODATUM;
with STK[TOP] do
begin
CODESTART := NEWINSTREC;
DTYPE := TYPM;
FPA.WHICH := MEM;
FPA.MEMADR.LVL := 0;
FPA.MEMADR.DSPLMT := NXTSTRDISP;
STARTBIT := NXTSTRDISP mod WORDCHARS * CHARBITS;
for I := 1 to SLGTH do
begin
if STARTBIT = 0 then
EMIT_ZEROS1WORD (STRINGAREA, STRINGAR_CPTR);
PUTFIELD (STRINGAR_CPTR↑.CODEWORD, STARTBIT,
CHARBITS, ord(SVAL[I])-CHARDIF ); (*CHARDIF*)
STARTBIT := (STARTBIT + CHARBITS) mod WORDBITS;
end;
NXTSTRDISP := NXTSTRDISP + SLGTH;
end (*with STK[TOP] do*);
end (*PLCA*);
PLOD, PLDO :
begin
if OPC = PLDO then
begin OPC := PLOD; I2 := I1; I1 := 1;
end;
PUSHTOP; STK[TOP] := ZERODATUM;
if I2 mod ALIGNBNDRY[TYP] <> 0 then
ERROR (WALIGNMENT_ERROR);
with STK[TOP] do
begin
CODESTART := NEWINSTREC;
DTYPE := TYP;
NVPAS := 1;
VPA1.VPAIND := IND1;
VPA1.VPA.WHICH := MEM;
VPA1.VPA.MEMADR.LVL := I1;
VPA1.VPA.MEMADR.DSPLMT := I2;
TRANSLATE_LVLDSP (VPA1.VPA);
if TYP = TYPB then BREPRES := BINTVAL;
end (*with STK[TOP] do*);
end (*PLOD, PLDO*);
PLDA, PLAO :
begin
if OPC = PLAO then
begin OPC := PLDA; I2 := I1; I1 := 1;
end;
PUSHTOP; STK[TOP] := ZERODATUM;
with STK[TOP] do
begin
CODESTART := NEWINSTREC;
DTYPE := TYPA;
FPA.WHICH := MEM;
FPA.MEMADR.LVL := I1;
FPA.MEMADR.DSPLMT := I2;
TRANSLATE_LVLDSP (FPA);
end (*with STK[TOP] do*);
end (*PLDA, PLAO*);
PIND :
begin
with STK[TOP] do
begin
if DTYPE<>TYPA then
if DTYPE=TYPN then ERROR (WNULLREF)
else if DTYPE=TYPM then ERROR (WLOADING_STRING)
else ERROR (WNOT_AN_ADDR);
if I1=0 then MAXFINALIND:=IND1 else MAXFINALIND:=IND0;
while FINALIND > MAXFINALIND do
SIMPLIFY (TOP);
if FPA.WHICH=RGS then
ERROR (WINDEXING_IN_PARMS);
FPA.MEMADR.DSPLMT := FPA.MEMADR.DSPLMT + I1;
if NVPAS = 0 then
begin (*move FPA to VPA*)
NVPAS := 1;
VPA1.VPAIND := IND1;
VPA1.VPA := FPA;
FPA := ZEROFPA;
end (*move FPA to VPA*)
else if (NVPAS=1) and (FPA=ZEROFPA) then
begin (*increase indirection on single VPA*)
if VPA1.VSHIFT<>0 then
ERROR (WINDEX_WITHOUT_BASE);
if VPA1.VPAIND = IND1 then VPA1.VPAIND := IND2
else FINALIND := succ(FINALIND);
end (*increase indirection on single VPA*)
else
(*the datum has multiple parts*)
FINALIND := succ(FINALIND);
DTYPE := TYP;
end (*with STK[TOP] do*);
end (*PIND*);
PSTO :
begin
STORE (TOP-1, TOP);
FREEDATUMREGS (TOP); POPTOP;
FREEDATUMREGS (TOP); POPTOP;
end (*PSTO*);
PSTR, PSRO :
begin
if OPC = PSRO then
begin OPC := PSTR; I2 := I1; I1 := 1;
end;
if I2 mod ALIGNBNDRY[TYP] <> 0 then
ERROR (WALIGNMENT_ERROR);
STK[TMPD1] := ZERODATUM;
with STK[TMPD1] do
begin
CODESTART := STK[TOP].CODESTART;
DTYPE := TYPA;
FPA.WHICH := MEM;
FPA.MEMADR.LVL := I1;
FPA.MEMADR.DSPLMT := I2;
TRANSLATE_LVLDSP (FPA);
end;
STORE (TMPD1, TOP);
FREEDATUMREGS (TOP);
POPTOP;
FREEDATUMREGS (TMPD1); (*This should be superfluous.*)
end (*PSTR, PSRO*);
end (*case OPC of*);
if ord(OPC) <= MAXSETEL then
if (OPC in [PFJP,PUJP,PXJP,PMOV,PSRO,PSTO,PSTR,PLAB])
and (TOP <> BOT-1) then
ERROR (WSTACK_NON_EMPTY);
end (*ASMNXTINST*);
(** READNXTINST_CLASS: READNXTINST READNAM READTYP READINT READREAL READSET READSET **)
(**)
procedure READNXTINST;
(*Read next P-Code instruction and convert it to internal form.*)
var CH : char;
procedure READNAM (var NAM : NAMEREC);
(*Skip initial blanks and commas and read a
label or procedure identifier into NAM.*)
var I : 0..8;
CH : char;
begin
while (INPUT↑=' ') or (INPUT↑=',') do
get (INPUT);
NAM.NAM := ' ';
I := 0;
repeat
I := I + 1;
READ (INPUT, CH);
NAM.NAM[I] := CH
until (I=8) or (INPUT↑=' ') or (INPUT↑=',');
while (INPUT↑<>' ') and (INPUT↑<>',') do
get (INPUT);
NAM.LEN := I;
end (*READNAM*);
procedure READTYP (var TYP : OPNDTYPE);
(*Skip initial blanks and commas and read a
type character. Translate it into an
OPNDTYPE and return it in TYP.*)
var CH : char;
begin
repeat
READ (INPUT, CH)
until (CH <> ' ') and (CH <> ',');
TYP := FIRSTTYPE;
while (TYP < LASTTYPE) and (TYPECODE[TYP] <> CH) do
TYP := succ(TYP);
if TYPECODE[TYP] <> CH then
ERROR (WINVALID_TYPE_CODE);
end (*READTYP*);
procedure READINT (var I : integer);
(*Skip initial blanks and commas and read an
integer into I.*)
begin
while (INPUT↑=' ') or (INPUT↑=',') do
get (INPUT);
READ (INPUT, I);;
end (*READINT*);
procedure READREAL (var R : real);
(*Skip initial blanks and commas and read a
real number into R.*)
begin
while (INPUT↑=' ') or (INPUT↑=',') do
get (INPUT);
READ (INPUT, R);;
end (*READREAL*);
(* Comment out the 370 version...
procedure READSET(var S : SETREP);
"*Read an input-format set and convert it to a SETREP,
returning it in S. This procedure changes when
sets get bigger for the real machine.*"
var SETINT :
record
DUMMY : integer; "*alignment (not needed?)*"
case BIT of
0 : (S : SETREP);
1 : (I : array[1..2] of integer)
end "*SETINT*";
INT1, INT2 : integer;
begin
while INPUT↑ <> '(' do get(INPUT);
get(INPUT);
READINT(INT1);
READINT(INT2);
SETINT.I[1] := INT1*TWOEXP[16] + INT2;
READINT(INT1);
READINT(INT2);
SETINT.I[2] := INT1*TWOEXP[16] + INT2;
S := SETINT.S
end "*READSET*";
...*)
procedure READSET(var S : SETREP);
(*Read an input-format set and convert it to a SETREP,
returning it in S. This procedure changes when
sets get bigger for the real machine. PDP-10 VERSION *)
var I, J, N : integer;
INTS : array[1..4] of integer;
begin
while INPUT↑ <> '(' do get(INPUT);
get(INPUT);
for I := 1 to 4 do READINT(INTS[I]);
S := [];
N := 0;
for I := 4 downto 1 do
for J := 1 to 16 do
begin
if odd(INTS[I]) then S := S + [N];
INTS[I] := INTS[I] div 2;
N := N + 1
end
end (*READSET*);
begin (*READNXTINST*)
if INPUT↑ <> ' ' then READNAM (NAM0);
repeat get(INPUT) until INPUT↑ <> ' ';
(* READ(MNEM); *)
READ(CH); MNEM[1] := CH;
READ(CH); MNEM[2] := CH;
READ(CH); MNEM[3] := CH;
OPC := MNEM_TO_OPC(MNEM);
case OPC of
PSTP : (*null case*);
PENT : begin
READTYP (TYP);
READINT (I1);
READNAM (NAM1);
READNAM (NAM2);
READINT (I2);
READINT (I3);
READINT (I4);
end;
PMST : begin
READINT (I1);
READINT (I2);
READINT (I3);
end;
PLAB : (*null case*);
PDEF : READINT (I1);
PSST : begin
READTYP (TYP);
READNAM (NAM1);
READINT (I1);
READINT (I2);
READINT (I3);
READINT (I4);
READINT (I5);
end;
PTOF : READNAM (NAM1);
PTON : begin
READNAM (NAM1);
if NAM1.NAM <> 'PCODE ' then
begin
READNAM (NAM2);
if NAM2.NAM[1] = 'A' then
begin
if NAM1.NAM <> 'S1CODE ' then
READINT (I1)
end
else if NAM2.NAM[1] <> 'P' then
ERROR (WINVAL_TRACE);
end;
end;
(*opcode class 1*)
PABI, PABR, PADI, PADR, PAND, PCHR, PDIF, PDVI, PDVR,
PEOF, PFLO, PFLT, PINN, PINT, PIOR, PMOD, PMPI, PMPR,
PNGI, PNGR, PNOT, PODD, PORD, PPRE, PRST, PSAV, PSBI,
PSBR, PSGS, PSQI, PSQR, PSUC, PTRC, PUNI :
(*null case*);
(*opcode class 2*)
PBGN, PIXA, PLAO, PLOC, PMOV, PNEW :
READINT (I1);
(*opcode class 3*)
PLDA:
begin
READINT (I1);
READINT (I2);
end;
(*opcode class 4*)
PFJP, PUJP, PXJP :
READNAM (NAM1);
(*opcode class 5*)
PEQU, PGEQ, PGRT, PLEQ, PLES, PNEQ :
begin
READTYP (TYP);
if TYP = TYPM then READINT (I1);
end;
(*opcode class 6*)
PRET, PSTO, PPAR :
READTYP (TYP);
(*opcode class 7*)
PDEC, PINC, PIND, PLDO, PSRO :
begin
READTYP (TYP);
READINT (I1);
end;
(*opcode class 8*)
PCHK, PLOD, PSTR :
begin
READTYP (TYP);
READINT (I1);
READINT (I2);
end;
PCSP : READNAM (NAM1);
PCUP : begin
READTYP (TYP);
READINT (I1);
READNAM (NAM1);
end;
PLDC : begin
READTYP (TYP);
case TYP of
TYPI : READINT (I1);
TYPC : begin
READ (CH, CH, CH);
I1 := ord(CH) - CHARDIF; (*CHARDIF*)
end;
TYPR : READREAL (R1);
TYPN : (*null case*);
TYPB : READINT (I1);
TYPS : READSET (P1);
end (*case TYP of*);
end (*PLDC*);
PLCA : begin
READ (CH, CH, CH);
SLGTH := 0;
while (CH<>'''') or (INPUT↑='''') do
begin
SLGTH := SLGTH + 1;
SVAL[SLGTH] := CH;
if CH = '''' then READ (CH);
READ (CH);
end (*while*);
end (*PLCA*);
end (*case OPC of*);
READLN(INPUT);
end (*READNXTINST*);
(** INITIALIZE_CLASS: INITIALIZE ENTER_OPC ENTER_CSP INIT1 **)
(**)
procedure INITIALIZE;
var
I, N : integer;
T, T1, T2 : OPNDTYPE;
S1OP : S1OPCODE;
procedure ENTER_OPC (NAM : CHAR3; OPC : P_OPCODE);
var H : 0..OPCHTSIZEM1;
begin
H := OPC_HASH(NAM);
while OPCHASHTAB[H].OPCNAM <> ' ' do
H := (H + 1) mod OPCHTSIZE;
OPCHASHTAB[H].OPCNAM := NAM;
OPCHASHTAB[H].OPC := OPC;
end (*ENTER_OPC*);
procedure ENTER_CSP (NAM : CHAR3; CSP : P_STANDARDPROC);
var H : 0..CSPHTSIZEM1;
NAMALFA : ALFA;
begin
NAMALFA := ' ';
NAMALFA[1]:=NAM[1]; NAMALFA[2]:=NAM[2]; NAMALFA[3]:=NAM[3];
H := CSP_HASH(NAMALFA);
while CSPHASHTAB[H].CSPNAM.NAM <> ' ' do
H := (H + 1) mod CSPHTSIZE;
CSPHASHTAB[H].CSPNAM.NAM := NAMALFA;
CSPHASHTAB[H].CSPNAM.LEN := 3;
CSPHASHTAB[H].CSP := CSP;
end (*ENTER_CSP*);
procedure INIT1;
begin
ZEROS1WORD.LHALF := 0; ZEROS1WORD.RHALF := 0;
with EMPTY_OP do
begin
X := 0;
REG := 0; F := 0;
FIXUP := NOFIX; FIXPTR := nil;
XW.FMT := XW_EV; XW.P := 0;
XW.V := 0; XW.D := 0;
XW.I := 0; XW.S := 0;
XW.ADDR := 0; XW.REG := 0;
XW.DISP := 0;
end (*EMPTY_OP*);
with ZERO_OP do
begin
X := 0;
REG := 1; F := 0;
FIXUP := NOFIX; FIXPTR := nil;
XW.FMT := XW_C; XW.VAL := ZEROS1WORD;
end (*ZERO_OP*);
with EXTENDED_ZERO_OP do
begin
X := 1;
REG := 1; F := 1;
FIXUP := NOFIX; FIXPTR := nil;
XW.FMT := XW_C; XW.VAL := ZEROS1WORD;
end (*EXTENDED_ZERO_OP*);
with EMPTYCODELIST do
begin
NWORDS := 0;
FIRST := nil; LAST := nil;
end (*EMPTYCODELIST*);
with EMPTYJUMPLIST do
begin
NWORDS := 0;
FIRST := nil; LAST := nil;
end (*EMPTYJUMPLIST*);
with ZEROFPA do
begin
WHICH := MEM;
MEMADR.LVL := 0; MEMADR.DSPLMT := 0;
end (*ZEROFPA*);
with ZEROVPA do
begin
VSHIFT := 0; VPAIND := IND1;
VPA.WHICH := MEM;
VPA.MEMADR.LVL := 0;
VPA.MEMADR.DSPLMT := 0;
end (*ZEROVPA*);
with ZERODATUM do
begin
CODESTART := nil;
DTYPE := TYPP; (*no legal datum should be*)
BREPRES := BINTVAL;
BTRUELIST := EMPTYJUMPLIST;
BFALSELIST := EMPTYJUMPLIST;
BFALLTHRUSKIPLOC := nil;
BJUMPON := false;
PCNST := [ ]; RCNST := 0.0;
FINALIND := IND0; FPA := ZEROFPA;
NVPAS := 0;
VPA1 := ZEROVPA; VPA2 := ZEROVPA;
end (*ZERODATUM*);
with NESTDISPLAY[0] do
begin (*Set up dummy entry to allow
unmapped absolute addressing.*)
PROCTYPE := TYPP;
PROCNAM.NAM := 'DUMMY ';
PROCNAM.LEN := 5;
FIRSTPARMAREA := MIN_ON_COMP_MACH;
SECONDPARMAREA := MIN_ON_COMP_MACH;
VARAREA := MIN_ON_COMP_MACH;
OFFSET_IN_VARS := MIN_ON_COMP_MACH;
(*Here are the relevant ones.*)
LCBEFPAR := MAX_ON_COMP_MACH;
REGPARMAREA := 0;
LOCALDATAOFFSET := 0;
LOCALDATATRANSLATION := 0;
end (*NESTDISPLAY[0]*);
REG_OPERAND (UNUSED_OP, S1R0); (*unused operands must specify R0*)
REG_OPERAND (OPNDRTB, S1RTB);
REG_OPERAND (OPNDRSP, S1RSP);
SEG_EP_RELPC := SEG_START_RELPC + SEG_EP_DISP;
FIRSTTYPE := ILLARITH; LASTTYPE := TYPJ;
FIRSTS1OP := XILLEGAL; LASTS1OP := XXOR_Q;
TWOEXP[0] := 1;
for I := 1 to MAX_EXP_ON_COMP_MACH do TWOEXP[I] := 2 * TWOEXP[I-1];
MAXTMPS1REG := MINPARS1REG - 1;
MINDSPS1REG := MAXDSPS1REG + 1;
JUMPTABLE_IN_PROGRESS := false;
TYPECODE[TYPA] := 'A';
TYPECODE[TYPB] := 'B';
TYPECODE[TYPC] := 'C';
TYPECODE[TYPD] := 'D';
TYPECODE[TYPH] := 'H';
TYPECODE[TYPI] := 'I';
TYPECODE[TYPJ] := 'J';
TYPECODE[TYPM] := 'M';
TYPECODE[TYPN] := 'N';
TYPECODE[TYPP] := 'P';
TYPECODE[TYPQ] := 'Q';
TYPECODE[TYPR] := 'R';
TYPECODE[TYPS] := 'S';
TYPECODE[TYPX] := 'X';
ALIGNBNDRY[TYPA] := WORDUNITS;
ALIGNBNDRY[TYPB] := QUARTERWORDUNITS;
ALIGNBNDRY[TYPC] := QUARTERWORDUNITS;
ALIGNBNDRY[TYPD] := WORDUNITS;
ALIGNBNDRY[TYPH] := HALFWORDUNITS;
ALIGNBNDRY[TYPI] := WORDUNITS;
ALIGNBNDRY[TYPJ] := 0;
ALIGNBNDRY[TYPM] := WORDUNITS;
ALIGNBNDRY[TYPN] := WORDUNITS;
ALIGNBNDRY[TYPP] := 0;
ALIGNBNDRY[TYPQ] := QUARTERWORDUNITS;
ALIGNBNDRY[TYPR] := WORDUNITS;
ALIGNBNDRY[TYPS] := WORDUNITS;
ALIGNBNDRY[TYPX] := WORDUNITS;
S1SIZE[TYPA] := S1S; S1SIZE[TYPM] := S1S;
S1SIZE[TYPB] := S1Q; S1SIZE[TYPN] := S1S;
S1SIZE[TYPC] := S1Q; S1SIZE[TYPP] := S1Q;
S1SIZE[TYPD] := S1D; S1SIZE[TYPQ] := S1Q;
S1SIZE[TYPH] := S1H; S1SIZE[TYPR] := S1S;
S1SIZE[TYPI] := S1S; S1SIZE[TYPS] := S1D;
S1SIZE[TYPJ] := S1Q; S1SIZE[TYPX] := S1D;
FUNCUNITS[TYPA] := WORDUNITS;
FUNCUNITS[TYPB] := WORDUNITS;
FUNCUNITS[TYPC] := WORDUNITS;
FUNCUNITS[TYPD] := DOUBLEWORDUNITS;
FUNCUNITS[TYPH] := WORDUNITS;
FUNCUNITS[TYPI] := WORDUNITS;
FUNCUNITS[TYPJ] := 0;
FUNCUNITS[TYPM] := WORDUNITS;
FUNCUNITS[TYPN] := WORDUNITS;
FUNCUNITS[TYPP] := 0;
FUNCUNITS[TYPQ] := WORDUNITS;
FUNCUNITS[TYPR] := WORDUNITS;
FUNCUNITS[TYPS] := DOUBLEWORDUNITS;
FUNCUNITS[TYPX] := DOUBLEWORDUNITS;
for T := FIRSTTYPE to LASTTYPE do
begin
IS_DOUBLE[T] := (T in [TYPD, TYPS, TYPX]);
IS_SINGLE[T] := (T in [TYPA, TYPI, TYPM, TYPN, TYPR]);
IS_INTEGER[T] := (T in [TYPQ, TYPH, TYPI, TYPD]);
IS_REAL[T] := (T in [TYPX, TYPR]);
end (*for T*);
SKP_NON_X[TYPA] := XILLEGAL; SKP_NON_X[TYPM] := XILLEGAL;
SKP_NON_X[TYPB] := XSKP_NON_Q; SKP_NON_X[TYPN] := XILLEGAL;
SKP_NON_X[TYPC] := XSKP_NON_Q; SKP_NON_X[TYPP] := XILLEGAL;
SKP_NON_X[TYPD] := XSKP_NON_D; SKP_NON_X[TYPQ] := XSKP_NON_Q;
SKP_NON_X[TYPH] := XSKP_NON_H; SKP_NON_X[TYPR] := XILLEGAL;
SKP_NON_X[TYPI] := XSKP_NON_S; SKP_NON_X[TYPS] := XILLEGAL;
SKP_NON_X[TYPJ] := XILLEGAL; SKP_NON_X[TYPX] := XILLEGAL;
MOV_X_X[TYPA] := XMOV_S_S; MOV_X_X[TYPM] := XMOV_S_S;
MOV_X_X[TYPB] := XMOV_Q_Q; MOV_X_X[TYPN] := XMOV_S_S;
MOV_X_X[TYPC] := XMOV_Q_Q; MOV_X_X[TYPP] := XILLEGAL;
MOV_X_X[TYPD] := XMOV_D_D; MOV_X_X[TYPQ] := XMOV_Q_Q;
MOV_X_X[TYPH] := XMOV_H_H; MOV_X_X[TYPR] := XMOV_S_S;
MOV_X_X[TYPI] := XMOV_S_S; MOV_X_X[TYPS] := XMOV_D_D;
MOV_X_X[TYPJ] := XILLEGAL; MOV_X_X[TYPX] := XMOV_D_D;
MOVMQ_N[1] := XMOV_Q_Q; MOVMQ_N[2] := XMOVMQ_2;
MOVMQ_N[3] := XMOVMQ_3; MOVMQ_N[4] := XMOVMQ_4;
MOVMQ_N[5] := XMOVMQ_5; MOVMQ_N[6] := XMOVMQ_6;
MOVMQ_N[7] := XMOVMQ_7; MOVMQ_N[8] := XMOVMQ_8;
MOVMQ_N[9] := XMOVMQ_9; MOVMQ_N[10] := XMOVMQ_10;
MOVMQ_N[11] := XMOVMQ_11; MOVMQ_N[12] := XMOVMQ_12;
MOVMQ_N[13] := XMOVMQ_13; MOVMQ_N[14] := XMOVMQ_14;
MOVMQ_N[15] := XMOVMQ_15; MOVMQ_N[16] := XMOVMQ_16;
MOVMQ_N[17] := XMOVMQ_17; MOVMQ_N[18] := XMOVMQ_18;
MOVMQ_N[19] := XMOVMQ_19; MOVMQ_N[20] := XMOVMQ_20;
MOVMQ_N[21] := XMOVMQ_21; MOVMQ_N[22] := XMOVMQ_22;
MOVMQ_N[23] := XMOVMQ_23; MOVMQ_N[24] := XMOVMQ_24;
MOVMQ_N[25] := XMOVMQ_25; MOVMQ_N[26] := XMOVMQ_26;
MOVMQ_N[27] := XMOVMQ_27; MOVMQ_N[28] := XMOVMQ_28;
MOVMQ_N[29] := XMOVMQ_29; MOVMQ_N[30] := XMOVMQ_30;
MOVMQ_N[31] := XMOVMQ_31; MOVMQ_N[32] := XMOVMQ_32;
MOVMS_N[1] := XMOV_S_S; MOVMS_N[2] := XMOVMS_2; (*ALS*)
MOVMS_N[3] := XMOVMS_3; MOVMS_N[4] := XMOVMS_4;
MOVMS_N[5] := XMOVMS_5; MOVMS_N[6] := XMOVMS_6;
MOVMS_N[7] := XMOVMS_7; MOVMS_N[8] := XMOVMS_8;
MOVMS_N[9] := XMOVMS_9; MOVMS_N[10] := XMOVMS_10;
MOVMS_N[11] := XMOVMS_11; MOVMS_N[12] := XMOVMS_12;
MOVMS_N[13] := XMOVMS_13; MOVMS_N[14] := XMOVMS_14;
MOVMS_N[15] := XMOVMS_15; MOVMS_N[16] := XMOVMS_16;
MOVMS_N[17] := XMOVMS_17; MOVMS_N[18] := XMOVMS_18;
MOVMS_N[19] := XMOVMS_19; MOVMS_N[20] := XMOVMS_20;
MOVMS_N[21] := XMOVMS_21; MOVMS_N[22] := XMOVMS_22;
MOVMS_N[23] := XMOVMS_23; MOVMS_N[24] := XMOVMS_24;
MOVMS_N[25] := XMOVMS_25; MOVMS_N[26] := XMOVMS_26;
MOVMS_N[27] := XMOVMS_27; MOVMS_N[28] := XMOVMS_28;
MOVMS_N[29] := XMOVMS_29; MOVMS_N[30] := XMOVMS_30;
MOVMS_N[31] := XMOVMS_31; MOVMS_N[32] := XMOVMS_32; (*ALS*)
ABS_X[TYPA] := XILLEGAL; ABS_X[TYPM] := XILLEGAL;
ABS_X[TYPB] := XILLEGAL; ABS_X[TYPN] := XILLEGAL;
ABS_X[TYPC] := XILLEGAL; ABS_X[TYPP] := XILLEGAL;
ABS_X[TYPD] := XABS_D; ABS_X[TYPQ] := XABS_Q;
ABS_X[TYPH] := XABS_H; ABS_X[TYPR] := XABS_S;
ABS_X[TYPI] := XABS_S; ABS_X[TYPS] := XILLEGAL;
ABS_X[TYPJ] := XILLEGAL; ABS_X[TYPX] := XABS_D;
NEG_X[TYPA] := XILLEGAL; NEG_X[TYPM] := XILLEGAL;
NEG_X[TYPB] := XILLEGAL; NEG_X[TYPN] := XILLEGAL;
NEG_X[TYPC] := XILLEGAL; NEG_X[TYPP] := XILLEGAL;
NEG_X[TYPD] := XNEG_D; NEG_X[TYPQ] := XNEG_Q;
NEG_X[TYPH] := XNEG_H; NEG_X[TYPR] := XNEG_S;
NEG_X[TYPI] := XNEG_S; NEG_X[TYPS] := XILLEGAL;
NEG_X[TYPJ] := XILLEGAL; NEG_X[TYPX] := XNEG_D;
FLOAT_S_X[TYPA] := XILLEGAL;
FLOAT_S_X[TYPB] := XILLEGAL;
FLOAT_S_X[TYPC] := XILLEGAL;
FLOAT_S_X[TYPD] := XFLOAT_S_D;
FLOAT_S_X[TYPH] := XFLOAT_S_H;
FLOAT_S_X[TYPI] := XFLOAT_S_S;
FLOAT_S_X[TYPJ] := XILLEGAL;
FLOAT_S_X[TYPM] := XILLEGAL;
FLOAT_S_X[TYPN] := XILLEGAL;
FLOAT_S_X[TYPP] := XILLEGAL;
FLOAT_S_X[TYPQ] := XFLOAT_S_Q;
FLOAT_S_X[TYPR] := XILLEGAL;
FLOAT_S_X[TYPS] := XILLEGAL;
FLOAT_S_X[TYPX] := XILLEGAL;
FIX_DM_S_X[TYPA] := XILLEGAL; FIX_DM_S_X[TYPM] := XILLEGAL;
FIX_DM_S_X[TYPB] := XILLEGAL; FIX_DM_S_X[TYPN] := XILLEGAL;
FIX_DM_S_X[TYPC] := XILLEGAL; FIX_DM_S_X[TYPP] := XILLEGAL;
FIX_DM_S_X[TYPD] := XILLEGAL; FIX_DM_S_X[TYPQ] := XILLEGAL;
FIX_DM_S_X[TYPH] := XILLEGAL; FIX_DM_S_X[TYPR] := XFX_DM_S_S;
FIX_DM_S_X[TYPI] := XILLEGAL; FIX_DM_S_X[TYPS] := XILLEGAL;
FIX_DM_S_X[TYPJ] := XILLEGAL; FIX_DM_S_X[TYPX] := XFX_DM_S_D;
SLR_N[0] := XSLR_0; SLR_N[1] := XSLR_1;
SLR_N[2] := XSLR_2; SLR_N[3] := XSLR_3;
SLR_N[4] := XSLR_4; SLR_N[5] := XSLR_5;
SLR_N[6] := XSLR_6; SLR_N[7] := XSLR_7;
SLR_N[8] := XSLR_8; SLR_N[9] := XSLR_9;
SLR_N[10] := XSLR_10; SLR_N[11] := XSLR_11;
SLR_N[12] := XSLR_12; SLR_N[13] := XSLR_13;
SLR_N[14] := XSLR_14; SLR_N[15] := XSLR_15;
SLR_N[16] := XSLR_16; SLR_N[17] := XSLR_17;
SLR_N[18] := XSLR_18; SLR_N[19] := XSLR_19;
SLR_N[20] := XSLR_20; SLR_N[21] := XSLR_21;
SLR_N[22] := XSLR_22; SLR_N[23] := XSLR_23;
SLR_N[24] := XSLR_24; SLR_N[25] := XSLR_25;
SLR_N[26] := XSLR_26; SLR_N[27] := XSLR_27;
SLR_N[28] := XSLR_28; SLR_N[29] := XSLR_29;
SLR_N[30] := XSLR_30; SLR_N[31] := XSLR_31;
SLRADR_N[0] := XSLRADR_0; SLRADR_N[1] := XSLRADR_1;
SLRADR_N[2] := XSLRADR_2; SLRADR_N[3] := XSLRADR_3;
SLRADR_N[4] := XSLRADR_4; SLRADR_N[5] := XSLRADR_5;
SLRADR_N[6] := XSLRADR_6; SLRADR_N[7] := XSLRADR_7;
SLRADR_N[8] := XSLRADR_8; SLRADR_N[9] := XSLRADR_9;
SLRADR_N[10] := XSLRADR_10; SLRADR_N[11] := XSLRADR_11;
SLRADR_N[12] := XSLRADR_12; SLRADR_N[13] := XSLRADR_13;
SLRADR_N[14] := XSLRADR_14; SLRADR_N[15] := XSLRADR_15;
SLRADR_N[16] := XSLRADR_16; SLRADR_N[17] := XSLRADR_17;
SLRADR_N[18] := XSLRADR_18; SLRADR_N[19] := XSLRADR_19;
SLRADR_N[20] := XSLRADR_20; SLRADR_N[21] := XSLRADR_21;
SLRADR_N[22] := XSLRADR_22; SLRADR_N[23] := XSLRADR_23;
SLRADR_N[24] := XSLRADR_24; SLRADR_N[25] := XSLRADR_25;
SLRADR_N[26] := XSLRADR_26; SLRADR_N[27] := XSLRADR_27;
SLRADR_N[28] := XSLRADR_28; SLRADR_N[29] := XSLRADR_29;
SLRADR_N[30] := XSLRADR_30; SLRADR_N[31] := XSLRADR_31;
BTRP_B_X[TYPA] := XBTRP_B_S; BTRP_B_X[TYPM] := XBTRP_B_S;
BTRP_B_X[TYPB] := XBTRP_B_Q; BTRP_B_X[TYPN] := XILLEGAL;
BTRP_B_X[TYPC] := XBTRP_B_Q; BTRP_B_X[TYPP] := XILLEGAL;
BTRP_B_X[TYPD] := XBTRP_B_D; BTRP_B_X[TYPQ] := XBTRP_B_Q;
BTRP_B_X[TYPH] := XBTRP_B_H; BTRP_B_X[TYPR] := XILLEGAL;
BTRP_B_X[TYPI] := XBTRP_B_S; BTRP_B_X[TYPS] := XILLEGAL;
BTRP_B_X[TYPJ] := XILLEGAL; BTRP_B_X[TYPX] := XILLEGAL;
BTRP_N_X[0,TYPA] := XBTRP_0_S;
BTRP_N_X[0,TYPB] := XBTRP_0_Q;
BTRP_N_X[0,TYPC] := XBTRP_0_Q;
BTRP_N_X[0,TYPD] := XBTRP_0_D;
BTRP_N_X[0,TYPH] := XBTRP_0_H;
BTRP_N_X[0,TYPI] := XBTRP_0_S;
BTRP_N_X[0,TYPJ] := XILLEGAL;
BTRP_N_X[0,TYPM] := XBTRP_0_S;
BTRP_N_X[0,TYPN] := XILLEGAL;
BTRP_N_X[0,TYPP] := XILLEGAL;
BTRP_N_X[0,TYPQ] := XBTRP_0_Q;
BTRP_N_X[0,TYPR] := XILLEGAL;
BTRP_N_X[0,TYPS] := XILLEGAL;
BTRP_N_X[0,TYPX] := XILLEGAL;
BTRP_N_X[1,TYPA] := XBTRP_1_S;
BTRP_N_X[1,TYPB] := XBTRP_1_Q;
BTRP_N_X[1,TYPC] := XBTRP_1_Q;
BTRP_N_X[1,TYPD] := XBTRP_1_D;
BTRP_N_X[1,TYPH] := XBTRP_1_H;
BTRP_N_X[1,TYPI] := XBTRP_1_S;
BTRP_N_X[1,TYPJ] := XILLEGAL;
BTRP_N_X[1,TYPM] := XBTRP_1_S;
BTRP_N_X[1,TYPN] := XILLEGAL;
BTRP_N_X[1,TYPP] := XILLEGAL;
BTRP_N_X[1,TYPQ] := XBTRP_1_Q;
BTRP_N_X[1,TYPR] := XILLEGAL;
BTRP_N_X[1,TYPS] := XILLEGAL;
BTRP_N_X[1,TYPX] := XILLEGAL;
end (*INIT1*);
(** INITIALIZE_CLASS: INIT2 **)
(**)
procedure INIT2;
begin
for T1 := FIRSTTYPE to LASTTYPE do
for T2 := FIRSTTYPE to LASTTYPE do
begin
MOV_X_Y[T1, T2] := XILLEGAL;
ARITH_RESULT_TYPE[T1, T2] := ILLARITH;
COMPARE_COERCE_TYPE[T1, T2] := ILLCOMP;
end (*for*);
MOV_X_Y [TYPA, TYPA] := XMOV_S_S;
MOV_X_Y [TYPA, TYPN] := XMOV_S_S;
MOV_X_Y [TYPA, TYPM] := XMOV_S_S;
MOV_X_Y [TYPB, TYPB] := XMOV_Q_Q;
MOV_X_Y [TYPC, TYPC] := XMOV_Q_Q;
MOV_X_Y [TYPS, TYPS] := XMOV_D_D;
MOV_X_Y [TYPX, TYPX] := XMOV_D_D;
MOV_X_Y [TYPX, TYPR] := XFTRANS_D_S;
MOV_X_Y [TYPR, TYPX] := XFTRANS_S_D;
MOV_X_Y [TYPR, TYPR] := XMOV_S_S;
MOV_X_Y [TYPQ, TYPQ] := XMOV_Q_Q;
MOV_X_Y [TYPQ, TYPH] := XTRANS_Q_H;
MOV_X_Y [TYPH, TYPQ] := XTRANS_H_Q;
MOV_X_Y [TYPH, TYPH] := XMOV_H_H;
MOV_X_Y [TYPQ, TYPI] := XTRANS_Q_S;
MOV_X_Y [TYPH, TYPI] := XTRANS_H_S;
MOV_X_Y [TYPI, TYPQ] := XTRANS_S_Q;
MOV_X_Y [TYPI, TYPH] := XTRANS_S_H;
MOV_X_Y [TYPI, TYPI] := XMOV_S_S;
MOV_X_Y [TYPQ, TYPD] := XTRANS_Q_D;
MOV_X_Y [TYPH, TYPD] := XTRANS_H_D;
MOV_X_Y [TYPI, TYPD] := XTRANS_S_D;
MOV_X_Y [TYPD, TYPQ] := XTRANS_D_Q;
MOV_X_Y [TYPD, TYPH] := XTRANS_D_H;
MOV_X_Y [TYPD, TYPI] := XTRANS_D_S;
MOV_X_Y [TYPD, TYPD] := XMOV_D_D;
for T1 := TYPQ to TYPI do
for T2 := TYPQ to TYPI do
ARITH_RESULT_TYPE[T1,T2] := TYPI;
for T := TYPQ to TYPD do
begin
ARITH_RESULT_TYPE[T,TYPD] := TYPD;
ARITH_RESULT_TYPE[TYPD,T] := TYPD;
end;
ARITH_RESULT_TYPE [TYPX,TYPX] := TYPX;
ARITH_RESULT_TYPE [TYPX,TYPR] := TYPX;
ARITH_RESULT_TYPE [TYPR,TYPX] := TYPX;
ARITH_RESULT_TYPE [TYPR,TYPR] := TYPR;
COMPARE_COERCE_TYPE [TYPA,TYPM] := TYPA;
COMPARE_COERCE_TYPE [TYPM,TYPA] := TYPA;
COMPARE_COERCE_TYPE [TYPA,TYPN] := TYPA;
COMPARE_COERCE_TYPE [TYPN,TYPA] := TYPA;
COMPARE_COERCE_TYPE [TYPA,TYPA] := TYPA;
COMPARE_COERCE_TYPE [TYPX,TYPX] := TYPX;
COMPARE_COERCE_TYPE [TYPR,TYPX] := TYPX;
COMPARE_COERCE_TYPE [TYPX,TYPR] := TYPX;
COMPARE_COERCE_TYPE [TYPR,TYPR] := TYPR;
COMPARE_COERCE_TYPE [TYPQ,TYPQ] := TYPQ;
COMPARE_COERCE_TYPE [TYPQ,TYPH] := TYPH;
COMPARE_COERCE_TYPE [TYPH,TYPQ] := TYPH;
COMPARE_COERCE_TYPE [TYPH,TYPH] := TYPH;
COMPARE_COERCE_TYPE [TYPQ,TYPI] := TYPI;
COMPARE_COERCE_TYPE [TYPH,TYPI] := TYPI;
COMPARE_COERCE_TYPE [TYPI,TYPQ] := TYPI;
COMPARE_COERCE_TYPE [TYPI,TYPH] := TYPI;
COMPARE_COERCE_TYPE [TYPI,TYPI] := TYPI;
COMPARE_COERCE_TYPE [TYPQ,TYPD] := TYPD;
COMPARE_COERCE_TYPE [TYPH,TYPD] := TYPD;
COMPARE_COERCE_TYPE [TYPI,TYPD] := TYPD;
COMPARE_COERCE_TYPE [TYPD,TYPQ] := TYPD;
COMPARE_COERCE_TYPE [TYPD,TYPH] := TYPD;
COMPARE_COERCE_TYPE [TYPD,TYPI] := TYPD;
COMPARE_COERCE_TYPE [TYPD,TYPD] := TYPD;
COMPARE_COERCE_TYPE [TYPB,TYPB] := TYPB;
COMPARE_COERCE_TYPE [TYPC,TYPC] := TYPC;
COMPARE_COERCE_TYPE [TYPS,TYPS] := TYPS;
REAL_ARITH_OP [S1S, PADR] := XFADD_S;
REAL_ARITH_OP [S1D, PADR] := XFADD_D;
REAL_ARITH_OP [S1S, PSBR] := XFSUB_S;
REAL_ARITH_OP [S1D, PSBR] := XFSUB_D;
REAL_ARITH_OP [S1S, PMPR] := XFMULT_S;
REAL_ARITH_OP [S1D, PMPR] := XFMULT_D;
REAL_ARITH_OP [S1S, PDVR] := XFDIV_S;
REAL_ARITH_OP [S1D, PDVR] := XFDIV_D;
COMPARE_OP [S1Q, PEQU] := XSKP_EQL_Q;
COMPARE_OP [S1Q, PNEQ] := XSKP_NEQ_Q;
COMPARE_OP [S1Q, PGEQ] := XSKP_GEQ_Q;
COMPARE_OP [S1Q, PGRT] := XSKP_GTR_Q;
COMPARE_OP [S1Q, PLEQ] := XSKP_LEQ_Q;
COMPARE_OP [S1Q, PLES] := XSKP_LSS_Q;
COMPARE_OP [S1H, PEQU] := XSKP_EQL_H;
COMPARE_OP [S1H, PNEQ] := XSKP_NEQ_H;
COMPARE_OP [S1H, PGEQ] := XSKP_GEQ_H;
COMPARE_OP [S1H, PGRT] := XSKP_GTR_H;
COMPARE_OP [S1H, PLEQ] := XSKP_LEQ_H;
COMPARE_OP [S1H, PLES] := XSKP_LSS_H;
COMPARE_OP [S1S, PEQU] := XSKP_EQL_S;
COMPARE_OP [S1S, PNEQ] := XSKP_NEQ_S;
COMPARE_OP [S1S, PGEQ] := XSKP_GEQ_S;
COMPARE_OP [S1S, PGRT] := XSKP_GTR_S;
COMPARE_OP [S1S, PLEQ] := XSKP_LEQ_S;
COMPARE_OP [S1S, PLES] := XSKP_LSS_S;
COMPARE_OP [S1D, PEQU] := XSKP_EQL_D;
COMPARE_OP [S1D, PNEQ] := XSKP_NEQ_D;
COMPARE_OP [S1D, PGEQ] := XSKP_GEQ_D;
COMPARE_OP [S1D, PGRT] := XSKP_GTR_D;
COMPARE_OP [S1D, PLEQ] := XSKP_LEQ_D;
COMPARE_OP [S1D, PLES] := XSKP_LSS_D;
BLKCMP_X_Q [PEQU] := XBLCMP_EQL_Q;
BLKCMP_X_Q [PNEQ] := XBLCMP_NEQ_Q;
BLKCMP_X_Q [PGEQ] := XBLCMP_GEQ_Q;
BLKCMP_X_Q [PGRT] := XBLCMP_GTR_Q;
BLKCMP_X_Q [PLEQ] := XBLCMP_LEQ_Q;
BLKCMP_X_Q [PLES] := XBLCMP_LSS_Q;
for I := 1 to MAXLVL do
LVL_TO_S1REG[I] := MAXDSPS1REG + 1 - I;
for I := 0 to MAXPAREGM1 do
PRM_TO_S1REG[I] := I + MINPARS1REG;
for I := FIRSTS1REG to LASTS1REG do
S1REG_TO_PRM[I] := 1000000;
for I := MINPARS1REG to (MAXPAREGM1+MINPARS1REG) do
S1REG_TO_PRM[I] := I - MINPARS1REG;
ZSEGTYPE_TO_CHARS [ZIS] := 'IS ';
ZSEGTYPE_TO_CHARS [ZDS] := 'DS ';
ZSEGTYPE_TO_CHARS [ZCM] := 'CM ';
ZESDTYPE_TO_CHARS [ZST] := 'ST ';
ZESDTYPE_TO_CHARS [ZIN] := 'IN ';
ZESDTYPE_TO_CHARS [ZDN] := 'DN ';
ZESDTYPE_TO_CHARS [ZAN] := 'AN ';
ZESRTYPE_TO_CHARS [ZIR] := 'IR ';
ZESRTYPE_TO_CHARS [ZDR] := 'DR ';
ZESRTYPE_TO_CHARS [ZAR] := 'AR ';
ZESRTYPE_TO_CHARS [ZXR] := 'XR ';
ZOPR_TO_CHARS [ZPLUS] := '+ ';
ZOPR_TO_CHARS [ZMINUS] := '- ';
ZIXFLAG_TO_CHAR [ZESD] := 'D';
ZIXFLAG_TO_CHAR [ZESR] := 'R';
ZIXFLAG_TO_CHAR [ZSEG] := 'S';
for I := 0 to OPCHTSIZEM1 do
begin
OPCHASHTAB[I].OPCNAM := ' ';
end;
ENTER_OPC ('ADR', PADR); ENTER_OPC ('SBR', PSBR);
ENTER_OPC ('MPR', PMPR); ENTER_OPC ('DVR', PDVR);
ENTER_OPC ('EQU', PEQU); ENTER_OPC ('NEQ', PNEQ);
ENTER_OPC ('GEQ', PGEQ); ENTER_OPC ('GRT', PGRT);
ENTER_OPC ('LEQ', PLEQ); ENTER_OPC ('LES', PLES);
ENTER_OPC ('ABI', PABI); ENTER_OPC ('ABR', PABR);
ENTER_OPC ('ADI', PADI); ENTER_OPC ('AND', PAND);
ENTER_OPC ('BGN', PBGN); ENTER_OPC ('CHK', PCHK);
ENTER_OPC ('CHR', PCHR); ENTER_OPC ('CSP', PCSP);
ENTER_OPC ('CUP', PCUP); ENTER_OPC ('DEC', PDEC);
ENTER_OPC ('DEF', PDEF); ENTER_OPC ('DIF', PDIF);
ENTER_OPC ('DVI', PDVI); ENTER_OPC ('ENT', PENT);
ENTER_OPC ('EOF', PEOF); ENTER_OPC ('FJP', PFJP);
ENTER_OPC ('FLO', PFLO); ENTER_OPC ('FLT', PFLT);
ENTER_OPC ('INC', PINC); ENTER_OPC ('IND', PIND);
ENTER_OPC ('INN', PINN); ENTER_OPC ('INT', PINT);
ENTER_OPC ('IOR', PIOR); ENTER_OPC ('IXA', PIXA);
ENTER_OPC ('LAB', PLAB); ENTER_OPC ('LAO', PLAO);
ENTER_OPC ('LAB', PLAB); ENTER_OPC ('LCA', PLCA);
ENTER_OPC ('LDA', PLDA); ENTER_OPC ('LDC', PLDC);
ENTER_OPC ('LDO', PLDO); ENTER_OPC ('LOC', PLOC);
ENTER_OPC ('LOD', PLOD); ENTER_OPC ('MOD', PMOD);
ENTER_OPC ('MOV', PMOV); ENTER_OPC ('MPI', PMPI);
ENTER_OPC ('MST', PMST); ENTER_OPC ('NEW', PNEW);
ENTER_OPC ('NGI', PNGI); ENTER_OPC ('NGR', PNGR);
ENTER_OPC ('NOT', PNOT); ENTER_OPC ('ODD', PODD);
ENTER_OPC ('ORD', PORD); ENTER_OPC ('PAR', PPAR);
ENTER_OPC ('PRE', PPRE); ENTER_OPC ('RET', PRET);
ENTER_OPC ('RST', PRST); ENTER_OPC ('SAV', PSAV);
ENTER_OPC ('SBI', PSBI); ENTER_OPC ('SGS', PSGS);
ENTER_OPC ('SQI', PSQI); ENTER_OPC ('SQR', PSQR);
ENTER_OPC ('SRO', PSRO); ENTER_OPC ('SST', PSST);
ENTER_OPC ('STO', PSTO); ENTER_OPC ('STP', PSTP);
ENTER_OPC ('STR', PSTR); ENTER_OPC ('SUC', PSUC);
ENTER_OPC ('TOF', PTOF); ENTER_OPC ('TON', PTON);
ENTER_OPC ('TRC', PTRC); ENTER_OPC ('UJP', PUJP);
ENTER_OPC ('UNI', PUNI); ENTER_OPC ('XJP', PXJP);
end (*INIT2*);
(** INITIALIZE_CLASS: INIT3 **)
(**)
procedure INIT3;
begin
for I := 0 to CSPHTSIZEM1 do
begin
CSPHASHTAB[I].CSPNAM.NAM := ' ';
CSPHASHTAB[I].CSPNAM.LEN := 1;
end;
ENTER_CSP ('ATN', QATN); ENTER_CSP ('EXP', QEXP);
ENTER_CSP ('SIN', QSIN); ENTER_CSP ('COS', QCOS);
ENTER_CSP ('LOG', QLOG); ENTER_CSP ('SQT', QSQT);
ENTER_CSP ('CLK', QCLK); ENTER_CSP ('XIT', QXIT);
ENTER_CSP ('TRP', QTRP); ENTER_CSP ('GET', QGET);
ENTER_CSP ('PUT', QPUT); ENTER_CSP ('RLN', QRLN);
ENTER_CSP ('WLN', QWLN); ENTER_CSP ('RES', QRES);
ENTER_CSP ('REW', QREW); ENTER_CSP ('RDC', QRDC);
ENTER_CSP ('RDI', QRDI); ENTER_CSP ('RDR', QRDR);
ENTER_CSP ('RDS', QRDS); ENTER_CSP ('WRC', QWRC);
ENTER_CSP ('RDB', QRDB); ENTER_CSP ('WRB', QWRB);
ENTER_CSP ('WRI', QWRI); ENTER_CSP ('WRR', QWRR);
ENTER_CSP ('WRS', QWRS); ENTER_CSP ('ELN', QELN);
ENTER_CSP ('EOF', QEOF); ENTER_CSP ('SIO', QSIO);
ENTER_CSP ('EIO', QEIO); ENTER_CSP ('NEW', QNEW);
ENTER_CSP ('SAV', QSAV); ENTER_CSP ('RST', QRST);
for S1OP := FIRSTS1OP to LASTS1OP do
REVERSE_OP[S1OP] := XILLEGAL;
REVERSE_OP[XADD_S] := XADD_S;
REVERSE_OP[XADD_D] := XADD_D;
REVERSE_OP[XAND_Q] := XAND_Q;
REVERSE_OP[XAND_D] := XAND_D;
REVERSE_OP[XAND_TC_D] := XAND_CT_D;
REVERSE_OP[XAND_CT_D] := XAND_TC_D;
REVERSE_OP[XFADD_S] := XFADD_S;
REVERSE_OP[XFADD_D] := XFADD_D;
REVERSE_OP[XFSUB_S] := XFSUBV_S;
REVERSE_OP[XFSUBV_S] := XFSUB_S;
REVERSE_OP[XFSUB_D] := XFSUBV_D;
REVERSE_OP[XFSUBV_D] := XFSUB_D;
REVERSE_OP[XFMULT_S] := XFMULT_S;
REVERSE_OP[XFMULT_D] := XFMULT_D;
REVERSE_OP[XFDIV_S] := XFDIVV_S;
REVERSE_OP[XFDIVV_S] := XFDIV_S;
REVERSE_OP[XFDIV_D] := XFDIVV_D;
REVERSE_OP[XFDIVV_D] := XFDIV_D;
REVERSE_OP[XMULT_S] := XMULT_S;
REVERSE_OP[XMULT_D] := XMULT_D;
REVERSE_OP[XNOP] := XNOP;
REVERSE_OP[XOR_Q] := XOR_Q;
REVERSE_OP[XOR_D] := XOR_D;
REVERSE_OP[XQUO_S] := XQUOV_S;
REVERSE_OP[XQUOV_S] := XQUO_S;
REVERSE_OP[XQUO_D] := XQUOV_D;
REVERSE_OP[XQUOV_D] := XQUO_D;
REVERSE_OP[XREM_S] := XREMV_S;
REVERSE_OP[XREMV_S] := XREM_S;
REVERSE_OP[XREM_D] := XREMV_D;
REVERSE_OP[XREMV_D] := XREM_D;
REVERSE_OP[XSHF_LF_D] := XSHFV_LF_D;
REVERSE_OP[XSHFV_LF_D] := XSHF_LF_D;
REVERSE_OP[XSHFA_LF_S] := XSHFAV_LF_S;
REVERSE_OP[XSHFAV_LF_S] := XSHFA_LF_S;
REVERSE_OP[XSUB_S] := XSUBV_S;
REVERSE_OP[XSUBV_S] := XSUB_S;
REVERSE_OP[XSUB_D] := XSUBV_D;
REVERSE_OP[XSUBV_D] := XSUB_D;
REVERSE_OP[XXOR_Q] := XXOR_Q;
OPFORMAT [XILLEGAL] := VFAKEOP;
OPFORMAT [XPLOC] := VFAKEOP;
OPFORMAT [XS1LOC] := VFAKEOP;
OPFORMAT [XFREEREG] := VFAKEOP; (*PBK*)
OPFORMAT [XABS_Q] := VXOP;
OPFORMAT [XABS_H] := VXOP;
OPFORMAT [XABS_S] := VXOP;
OPFORMAT [XABS_D] := VXOP;
OPFORMAT [XADD_S] := VTOP;
OPFORMAT [XADD_D] := VTOP;
OPFORMAT [XADJSP_UP] := VXOP;
OPFORMAT [XADJSP_DN] := VXOP;
OPFORMAT [XALLOC_1] := VXOP;
OPFORMAT [XAND_Q] := VTOP;
OPFORMAT [XAND_D] := VTOP;
OPFORMAT [XAND_TC_D] := VTOP;
OPFORMAT [XAND_CT_D] := VTOP;
OPFORMAT [XBLCMP_EQL_Q] := VXOP;
OPFORMAT [XBLCMP_NEQ_Q] := VXOP;
OPFORMAT [XBLCMP_GEQ_Q] := VXOP;
OPFORMAT [XBLCMP_GTR_Q] := VXOP;
OPFORMAT [XBLCMP_LEQ_Q] := VXOP;
OPFORMAT [XBLCMP_LSS_Q] := VXOP;
OPFORMAT [XBLKMOV] := VXOP;
OPFORMAT [XBTRP_B_Q] := VXOP;
OPFORMAT [XBTRP_B_H] := VXOP;
OPFORMAT [XBTRP_B_S] := VXOP;
OPFORMAT [XBTRP_B_D] := VXOP;
OPFORMAT [XBTRP_M1_Q] := VXOP;
OPFORMAT [XBTRP_M1_H] := VXOP;
OPFORMAT [XBTRP_M1_S] := VXOP;
OPFORMAT [XBTRP_M1_D] := VXOP;
OPFORMAT [XBTRP_0_Q] := VXOP;
OPFORMAT [XBTRP_0_H] := VXOP;
OPFORMAT [XBTRP_0_S] := VXOP;
OPFORMAT [XBTRP_0_D] := VXOP;
OPFORMAT [XBTRP_1_Q] := VXOP;
OPFORMAT [XBTRP_1_H] := VXOP;
OPFORMAT [XBTRP_1_S] := VXOP;
OPFORMAT [XBTRP_1_D] := VXOP;
OPFORMAT [XDEC_S] := VXOP;
OPFORMAT [XFX_DM_S_S] := VXOP;
OPFORMAT [XFX_DM_S_D] := VXOP;
OPFORMAT [XFLOAT_S_Q] := VXOP;
OPFORMAT [XFLOAT_S_H] := VXOP;
OPFORMAT [XFLOAT_S_S] := VXOP;
OPFORMAT [XFLOAT_S_D] := VXOP;
OPFORMAT [XFADD_S] := VTOP;
OPFORMAT [XFADD_D] := VTOP;
OPFORMAT [XFSUB_S] := VTOP;
OPFORMAT [XFSUBV_S] := VTOP;
OPFORMAT [XFSUB_D] := VTOP;
OPFORMAT [XFSUBV_D] := VTOP;
OPFORMAT [XFMULT_S] := VTOP;
OPFORMAT [XFMULT_D] := VTOP;
OPFORMAT [XFDIV_S] := VTOP;
OPFORMAT [XFDIVV_S] := VTOP;
OPFORMAT [XFDIV_D] := VTOP;
OPFORMAT [XFDIVV_D] := VTOP;
OPFORMAT [XFTRANS_S_D] := VXOP;
OPFORMAT [XFTRANS_D_S] := VXOP;
OPFORMAT [XHALT] := VJOP; (*BNDTRPKLU*)
OPFORMAT [XINC_S] := VXOP;
OPFORMAT [XJMPA] := VJOP;
OPFORMAT [XJMPZ_EQL_Q] := VJOP;
OPFORMAT [XJSR] := VJOP;
OPFORMAT [XMOV_A] := VXOP;
OPFORMAT [XMOV_Q_Q] := VXOP;
OPFORMAT [XMOV_Q_H] := VXOP;
OPFORMAT [XMOV_H_Q] := VXOP;
OPFORMAT [XMOV_H_H] := VXOP;
OPFORMAT [XMOV_Q_S] := VXOP;
OPFORMAT [XMOV_H_S] := VXOP;
OPFORMAT [XMOV_S_Q] := VXOP;
OPFORMAT [XMOV_S_H] := VXOP;
OPFORMAT [XMOV_S_S] := VXOP;
OPFORMAT [XMOV_Q_D] := VXOP;
OPFORMAT [XMOV_H_D] := VXOP;
OPFORMAT [XMOV_S_D] := VXOP;
OPFORMAT [XMOV_D_Q] := VXOP;
OPFORMAT [XMOV_D_H] := VXOP;
OPFORMAT [XMOV_D_S] := VXOP;
OPFORMAT [XMOV_D_D] := VXOP;
OPFORMAT [XMOVMQ_2] := VXOP;
OPFORMAT [XMOVMQ_3] := VXOP;
OPFORMAT [XMOVMQ_4] := VXOP;
OPFORMAT [XMOVMQ_5] := VXOP;
OPFORMAT [XMOVMQ_6] := VXOP;
OPFORMAT [XMOVMQ_7] := VXOP;
OPFORMAT [XMOVMQ_8] := VXOP;
OPFORMAT [XMOVMQ_9] := VXOP;
OPFORMAT [XMOVMQ_10] := VXOP;
OPFORMAT [XMOVMQ_11] := VXOP;
OPFORMAT [XMOVMQ_12] := VXOP;
OPFORMAT [XMOVMQ_13] := VXOP;
OPFORMAT [XMOVMQ_14] := VXOP;
OPFORMAT [XMOVMQ_15] := VXOP;
OPFORMAT [XMOVMQ_16] := VXOP;
OPFORMAT [XMOVMQ_17] := VXOP;
OPFORMAT [XMOVMQ_18] := VXOP;
OPFORMAT [XMOVMQ_19] := VXOP;
OPFORMAT [XMOVMQ_20] := VXOP;
OPFORMAT [XMOVMQ_21] := VXOP;
OPFORMAT [XMOVMQ_22] := VXOP;
OPFORMAT [XMOVMQ_23] := VXOP;
OPFORMAT [XMOVMQ_24] := VXOP;
OPFORMAT [XMOVMQ_25] := VXOP;
OPFORMAT [XMOVMQ_26] := VXOP;
OPFORMAT [XMOVMQ_27] := VXOP;
OPFORMAT [XMOVMQ_28] := VXOP;
OPFORMAT [XMOVMQ_29] := VXOP;
OPFORMAT [XMOVMQ_30] := VXOP;
OPFORMAT [XMOVMQ_31] := VXOP;
OPFORMAT [XMOVMQ_32] := VXOP;
OPFORMAT [XMOVMQ_64] := VXOP;
OPFORMAT [XMOVMQ_128] := VXOP;
OPFORMAT [XMOVMS_2] := VXOP; (*ALS*)
OPFORMAT [XMOVMS_3] := VXOP;
OPFORMAT [XMOVMS_4] := VXOP;
OPFORMAT [XMOVMS_5] := VXOP;
OPFORMAT [XMOVMS_6] := VXOP;
OPFORMAT [XMOVMS_7] := VXOP;
OPFORMAT [XMOVMS_8] := VXOP;
OPFORMAT [XMOVMS_9] := VXOP;
OPFORMAT [XMOVMS_10] := VXOP;
OPFORMAT [XMOVMS_11] := VXOP;
OPFORMAT [XMOVMS_12] := VXOP;
OPFORMAT [XMOVMS_13] := VXOP;
OPFORMAT [XMOVMS_14] := VXOP;
OPFORMAT [XMOVMS_15] := VXOP;
OPFORMAT [XMOVMS_16] := VXOP;
OPFORMAT [XMOVMS_17] := VXOP;
OPFORMAT [XMOVMS_18] := VXOP;
OPFORMAT [XMOVMS_19] := VXOP;
OPFORMAT [XMOVMS_20] := VXOP;
OPFORMAT [XMOVMS_21] := VXOP;
OPFORMAT [XMOVMS_22] := VXOP;
OPFORMAT [XMOVMS_23] := VXOP;
OPFORMAT [XMOVMS_24] := VXOP;
OPFORMAT [XMOVMS_25] := VXOP;
OPFORMAT [XMOVMS_26] := VXOP;
OPFORMAT [XMOVMS_27] := VXOP;
OPFORMAT [XMOVMS_28] := VXOP;
OPFORMAT [XMOVMS_29] := VXOP;
OPFORMAT [XMOVMS_30] := VXOP;
OPFORMAT [XMOVMS_31] := VXOP;
OPFORMAT [XMOVMS_32] := VXOP; (*ALS*)
OPFORMAT [XMULT_S] := VTOP;
OPFORMAT [XMULT_D] := VTOP;
OPFORMAT [XNEG_Q] := VXOP;
OPFORMAT [XNEG_H] := VXOP;
OPFORMAT [XNEG_S] := VXOP;
OPFORMAT [XNEG_D] := VXOP;
OPFORMAT [XNOP] := VXOP;
OPFORMAT [XOR_Q] := VTOP;
OPFORMAT [XOR_D] := VTOP;
OPFORMAT [XQUO_S] := VTOP;
OPFORMAT [XQUOV_S] := VTOP;
OPFORMAT [XQUO_D] := VTOP;
OPFORMAT [XQUOV_D] := VTOP;
OPFORMAT [XREM_S] := VTOP;
OPFORMAT [XREMV_S] := VTOP;
OPFORMAT [XREM_D] := VTOP;
OPFORMAT [XREMV_D] := VTOP;
OPFORMAT [XRETSR] := VXOP;
OPFORMAT [XSHF_LF_D] := VTOP;
OPFORMAT [XSHFV_LF_D] := VTOP;
OPFORMAT [XSHFA_LF_S] := VTOP;
OPFORMAT [XSHFAV_LF_S] := VTOP;
OPFORMAT [XSKP_EQL_Q] := VSOP;
OPFORMAT [XSKP_NEQ_Q] := VSOP;
OPFORMAT [XSKP_GEQ_Q] := VSOP;
OPFORMAT [XSKP_GTR_Q] := VSOP;
OPFORMAT [XSKP_LEQ_Q] := VSOP;
OPFORMAT [XSKP_LSS_Q] := VSOP;
OPFORMAT [XSKP_EQL_H] := VSOP;
OPFORMAT [XSKP_NEQ_H] := VSOP;
OPFORMAT [XSKP_GEQ_H] := VSOP;
OPFORMAT [XSKP_GTR_H] := VSOP;
OPFORMAT [XSKP_LEQ_H] := VSOP;
OPFORMAT [XSKP_LSS_H] := VSOP;
OPFORMAT [XSKP_EQL_S] := VSOP;
OPFORMAT [XSKP_NEQ_S] := VSOP;
OPFORMAT [XSKP_GEQ_S] := VSOP;
OPFORMAT [XSKP_GTR_S] := VSOP;
OPFORMAT [XSKP_LEQ_S] := VSOP;
OPFORMAT [XSKP_LSS_S] := VSOP;
OPFORMAT [XSKP_EQL_D] := VSOP;
OPFORMAT [XSKP_NEQ_D] := VSOP;
OPFORMAT [XSKP_GEQ_D] := VSOP;
OPFORMAT [XSKP_GTR_D] := VSOP;
OPFORMAT [XSKP_LEQ_D] := VSOP;
OPFORMAT [XSKP_LSS_D] := VSOP;
OPFORMAT [XSKP_NON_Q] := VSOP;
OPFORMAT [XSKP_NON_H] := VSOP;
OPFORMAT [XSKP_NON_S] := VSOP;
OPFORMAT [XSKP_NON_D] := VSOP;
OPFORMAT [XSKP_ANY_Q] := VSOP;
OPFORMAT [XSKP_ANY_H] := VSOP;
OPFORMAT [XSKP_ANY_S] := VSOP;
OPFORMAT [XSKP_ANY_D] := VSOP;
OPFORMAT [XSLR_0] := VXOP;
OPFORMAT [XSLR_1] := VXOP;
OPFORMAT [XSLR_2] := VXOP;
OPFORMAT [XSLR_3] := VXOP;
OPFORMAT [XSLR_4] := VXOP;
OPFORMAT [XSLR_5] := VXOP;
OPFORMAT [XSLR_6] := VXOP;
OPFORMAT [XSLR_7] := VXOP;
OPFORMAT [XSLR_8] := VXOP;
OPFORMAT [XSLR_9] := VXOP;
OPFORMAT [XSLR_10] := VXOP;
OPFORMAT [XSLR_11] := VXOP;
OPFORMAT [XSLR_12] := VXOP;
OPFORMAT [XSLR_13] := VXOP;
OPFORMAT [XSLR_14] := VXOP;
OPFORMAT [XSLR_15] := VXOP;
OPFORMAT [XSLR_16] := VXOP;
OPFORMAT [XSLR_17] := VXOP;
OPFORMAT [XSLR_18] := VXOP;
OPFORMAT [XSLR_19] := VXOP;
OPFORMAT [XSLR_20] := VXOP;
OPFORMAT [XSLR_21] := VXOP;
OPFORMAT [XSLR_22] := VXOP;
OPFORMAT [XSLR_23] := VXOP;
OPFORMAT [XSLR_24] := VXOP;
OPFORMAT [XSLR_25] := VXOP;
OPFORMAT [XSLR_26] := VXOP;
OPFORMAT [XSLR_27] := VXOP;
OPFORMAT [XSLR_28] := VXOP;
OPFORMAT [XSLR_29] := VXOP;
OPFORMAT [XSLR_30] := VXOP;
OPFORMAT [XSLR_31] := VXOP;
OPFORMAT [XSLRADR_0] := VXOP;
OPFORMAT [XSLRADR_1] := VXOP;
OPFORMAT [XSLRADR_2] := VXOP;
OPFORMAT [XSLRADR_3] := VXOP;
OPFORMAT [XSLRADR_4] := VXOP;
OPFORMAT [XSLRADR_5] := VXOP;
OPFORMAT [XSLRADR_6] := VXOP;
OPFORMAT [XSLRADR_7] := VXOP;
OPFORMAT [XSLRADR_8] := VXOP;
OPFORMAT [XSLRADR_9] := VXOP;
OPFORMAT [XSLRADR_10] := VXOP;
OPFORMAT [XSLRADR_11] := VXOP;
OPFORMAT [XSLRADR_12] := VXOP;
OPFORMAT [XSLRADR_13] := VXOP;
OPFORMAT [XSLRADR_14] := VXOP;
OPFORMAT [XSLRADR_15] := VXOP;
OPFORMAT [XSLRADR_16] := VXOP;
OPFORMAT [XSLRADR_17] := VXOP;
OPFORMAT [XSLRADR_18] := VXOP;
OPFORMAT [XSLRADR_19] := VXOP;
OPFORMAT [XSLRADR_20] := VXOP;
OPFORMAT [XSLRADR_21] := VXOP;
OPFORMAT [XSLRADR_22] := VXOP;
OPFORMAT [XSLRADR_23] := VXOP;
OPFORMAT [XSLRADR_24] := VXOP;
OPFORMAT [XSLRADR_25] := VXOP;
OPFORMAT [XSLRADR_26] := VXOP;
OPFORMAT [XSLRADR_27] := VXOP;
OPFORMAT [XSLRADR_28] := VXOP;
OPFORMAT [XSLRADR_29] := VXOP;
OPFORMAT [XSLRADR_30] := VXOP;
OPFORMAT [XSLRADR_31] := VXOP;
OPFORMAT [XSUB_S] := VTOP;
OPFORMAT [XSUBV_S] := VTOP;
OPFORMAT [XSUB_D] := VTOP;
OPFORMAT [XSUBV_D] := VTOP;
OPFORMAT [XTRANS_Q_Q] := VXOP;
OPFORMAT [XTRANS_Q_H] := VXOP;
OPFORMAT [XTRANS_H_Q] := VXOP;
OPFORMAT [XTRANS_H_H] := VXOP;
OPFORMAT [XTRANS_Q_S] := VXOP;
OPFORMAT [XTRANS_H_S] := VXOP;
OPFORMAT [XTRANS_S_Q] := VXOP;
OPFORMAT [XTRANS_S_H] := VXOP;
OPFORMAT [XTRANS_S_S] := VXOP;
OPFORMAT [XTRANS_Q_D] := VXOP;
OPFORMAT [XTRANS_H_D] := VXOP;
OPFORMAT [XTRANS_S_D] := VXOP;
OPFORMAT [XTRANS_D_Q] := VXOP;
OPFORMAT [XTRANS_D_H] := VXOP;
OPFORMAT [XTRANS_D_S] := VXOP;
OPFORMAT [XTRANS_D_D] := VXOP;
OPFORMAT [XXOR_Q] := VTOP;
end (*INIT3*);
(** INITIALIZE_CLASS: INIT4 **)
(**)
procedure INIT4;
begin
S1MNEM [XILLEGAL] := 'ILLEGAL ';
S1MNEM [XPLOC] := 'PLOC ';
S1MNEM [XS1LOC] := 'S1LOC ';
S1MNEM [XFREEREG] := 'FREEREG '; (*PBK*)
" START S1MNEM MARKER FOR OPS.PAS "
S1MNEM [XABS_Q] := 'ABS.Q ';
S1MNEM [XABS_H] := 'ABS.H ';
S1MNEM [XABS_S] := 'ABS.S ';
S1MNEM [XABS_D] := 'ABS.D ';
S1MNEM [XADD_S] := 'ADD.S ';
S1MNEM [XADD_D] := 'ADD.D ';
S1MNEM [XADJSP_UP] := 'ADJSP.UP ';
S1MNEM [XADJSP_DN] := 'ADJSP.DN ';
S1MNEM [XALLOC_1] := 'ALLOC.1 ';
S1MNEM [XAND_Q] := 'AND.Q ';
S1MNEM [XAND_D] := 'AND.D ';
S1MNEM [XAND_TC_D] := 'ANDTC.D ';
S1MNEM [XAND_CT_D] := 'ANDCT.D ';
S1MNEM [XBLCMP_EQL_Q] := 'BLKCMP.EQL.Q ';
S1MNEM [XBLCMP_NEQ_Q] := 'BLKCMP.NEQ.Q ';
S1MNEM [XBLCMP_GEQ_Q] := 'BLKCMP.GEQ.Q ';
S1MNEM [XBLCMP_GTR_Q] := 'BLKCMP.GTR.Q ';
S1MNEM [XBLCMP_LEQ_Q] := 'BLKCMP.LEQ.Q ';
S1MNEM [XBLCMP_LSS_Q] := 'BLKCMP.LSS.Q ';
S1MNEM [XBLKMOV] := 'BLKMOV ';
S1MNEM [XBTRP_B_Q] := 'BNDTRP.B.Q ';
S1MNEM [XBTRP_B_H] := 'BNDTRP.B.H ';
S1MNEM [XBTRP_B_S] := 'BNDTRP.B.S ';
S1MNEM [XBTRP_B_D] := 'BNDTRP.B.D ';
S1MNEM [XBTRP_M1_Q] := 'BNDTRP.M1.Q ';
S1MNEM [XBTRP_M1_H] := 'BNDTRP.M1.H ';
S1MNEM [XBTRP_M1_S] := 'BNDTRP.M1.S ';
S1MNEM [XBTRP_M1_D] := 'BNDTRP.M1.D ';
S1MNEM [XBTRP_0_Q] := 'BNDTRP.0.Q ';
S1MNEM [XBTRP_0_H] := 'BNDTRP.0.H ';
S1MNEM [XBTRP_0_S] := 'BNDTRP.0.S ';
S1MNEM [XBTRP_0_D] := 'BNDTRP.0.D ';
S1MNEM [XBTRP_1_Q] := 'BNDTRP.1.Q ';
S1MNEM [XBTRP_1_H] := 'BNDTRP.1.H ';
S1MNEM [XBTRP_1_S] := 'BNDTRP.1.S ';
S1MNEM [XBTRP_1_D] := 'BNDTRP.1.D ';
S1MNEM [XDEC_S] := 'DEC.S ';
S1MNEM [XFX_DM_S_S] := 'FIX.DM.S.S ';
S1MNEM [XFX_DM_S_D] := 'FIX.DM.S.D ';
S1MNEM [XFLOAT_S_Q] := 'FLOAT.S.Q ';
S1MNEM [XFLOAT_S_H] := 'FLOAT.S.H ';
S1MNEM [XFLOAT_S_S] := 'FLOAT.S.S ';
S1MNEM [XFLOAT_S_D] := 'FLOAT.S.D ';
S1MNEM [XFADD_S] := 'FADD.S ';
S1MNEM [XFADD_D] := 'FADD.D ';
S1MNEM [XFSUB_S] := 'FSUB.S ';
S1MNEM [XFSUBV_S] := 'FSUBV.S ';
S1MNEM [XFSUB_D] := 'FSUB.D ';
S1MNEM [XFSUBV_D] := 'FSUBV.D ';
S1MNEM [XFMULT_S] := 'FMULT.S ';
S1MNEM [XFMULT_D] := 'FMULT.D ';
S1MNEM [XFDIV_S] := 'FDIV.S ';
S1MNEM [XFDIVV_S] := 'FDIVV.S ';
S1MNEM [XFDIV_D] := 'FDIV.D ';
S1MNEM [XFDIVV_D] := 'FDIVV.D ';
S1MNEM [XFTRANS_S_D] := 'FTRANS.S.D ';
S1MNEM [XFTRANS_D_S] := 'FTRANS.D.S ';
S1MNEM [XHALT] := 'HALT '; (*BNDTRPKLU*)
S1MNEM [XINC_S] := 'INC.S ';
S1MNEM [XJMPA] := 'JMPA ';
S1MNEM [XJMPZ_EQL_Q] := 'JMPZ.EQL.Q ';
S1MNEM [XJSR] := 'JSR ';
S1MNEM [XMOV_A] := 'MOVADR ';
S1MNEM [XMOV_Q_Q] := 'MOV.Q.Q ';
S1MNEM [XMOV_Q_H] := 'MOV.Q.H ';
S1MNEM [XMOV_H_Q] := 'MOV.H.Q ';
S1MNEM [XMOV_H_H] := 'MOV.H.H ';
S1MNEM [XMOV_Q_S] := 'MOV.Q.S ';
S1MNEM [XMOV_H_S] := 'MOV.H.S ';
S1MNEM [XMOV_S_Q] := 'MOV.S.Q ';
S1MNEM [XMOV_S_H] := 'MOV.S.H ';
S1MNEM [XMOV_S_S] := 'MOV.S.S ';
S1MNEM [XMOV_Q_D] := 'MOV.Q.D ';
S1MNEM [XMOV_H_D] := 'MOV.H.D ';
S1MNEM [XMOV_S_D] := 'MOV.S.D ';
S1MNEM [XMOV_D_Q] := 'MOV.D.Q ';
S1MNEM [XMOV_D_H] := 'MOV.D.H ';
S1MNEM [XMOV_D_S] := 'MOV.D.S ';
S1MNEM [XMOV_D_D] := 'MOV.D.D ';
S1MNEM [XMOVMQ_2] := 'MOVMQ.2 ';
S1MNEM [XMOVMQ_3] := 'MOVMQ.3 ';
S1MNEM [XMOVMQ_4] := 'MOVMQ.4 ';
S1MNEM [XMOVMQ_5] := 'MOVMQ.5 ';
S1MNEM [XMOVMQ_6] := 'MOVMQ.6 ';
S1MNEM [XMOVMQ_7] := 'MOVMQ.7 ';
S1MNEM [XMOVMQ_8] := 'MOVMQ.8 ';
S1MNEM [XMOVMQ_9] := 'MOVMQ.9 ';
S1MNEM [XMOVMQ_10] := 'MOVMQ.10 ';
S1MNEM [XMOVMQ_11] := 'MOVMQ.11 ';
S1MNEM [XMOVMQ_12] := 'MOVMQ.12 ';
S1MNEM [XMOVMQ_13] := 'MOVMQ.13 ';
S1MNEM [XMOVMQ_14] := 'MOVMQ.14 ';
S1MNEM [XMOVMQ_15] := 'MOVMQ.15 ';
S1MNEM [XMOVMQ_16] := 'MOVMQ.16 ';
S1MNEM [XMOVMQ_17] := 'MOVMQ.17 ';
S1MNEM [XMOVMQ_18] := 'MOVMQ.18 ';
S1MNEM [XMOVMQ_19] := 'MOVMQ.19 ';
S1MNEM [XMOVMQ_20] := 'MOVMQ.20 ';
S1MNEM [XMOVMQ_21] := 'MOVMQ.21 ';
S1MNEM [XMOVMQ_22] := 'MOVMQ.22 ';
S1MNEM [XMOVMQ_23] := 'MOVMQ.23 ';
S1MNEM [XMOVMQ_24] := 'MOVMQ.24 ';
S1MNEM [XMOVMQ_25] := 'MOVMQ.25 ';
S1MNEM [XMOVMQ_26] := 'MOVMQ.26 ';
S1MNEM [XMOVMQ_27] := 'MOVMQ.27 ';
S1MNEM [XMOVMQ_28] := 'MOVMQ.28 ';
S1MNEM [XMOVMQ_29] := 'MOVMQ.29 ';
S1MNEM [XMOVMQ_30] := 'MOVMQ.30 ';
S1MNEM [XMOVMQ_31] := 'MOVMQ.31 ';
S1MNEM [XMOVMQ_32] := 'MOVMQ.32 ';
S1MNEM [XMOVMQ_64] := 'MOVMQ.64 ';
S1MNEM [XMOVMQ_128] := 'MOVMQ.128 ';
S1MNEM [XMOVMS_2] := 'MOVMS.2 '; (*ALS*)
S1MNEM [XMOVMS_3] := 'MOVMS.3 ';
S1MNEM [XMOVMS_4] := 'MOVMS.4 ';
S1MNEM [XMOVMS_5] := 'MOVMS.5 ';
S1MNEM [XMOVMS_6] := 'MOVMS.6 ';
S1MNEM [XMOVMS_7] := 'MOVMS.7 ';
S1MNEM [XMOVMS_8] := 'MOVMS.8 ';
S1MNEM [XMOVMS_9] := 'MOVMS.9 ';
S1MNEM [XMOVMS_10] := 'MOVMS.10 ';
S1MNEM [XMOVMS_11] := 'MOVMS.11 ';
S1MNEM [XMOVMS_12] := 'MOVMS.12 ';
S1MNEM [XMOVMS_13] := 'MOVMS.13 ';
S1MNEM [XMOVMS_14] := 'MOVMS.14 ';
S1MNEM [XMOVMS_15] := 'MOVMS.15 ';
S1MNEM [XMOVMS_16] := 'MOVMS.16 ';
S1MNEM [XMOVMS_17] := 'MOVMS.17 ';
S1MNEM [XMOVMS_18] := 'MOVMS.18 ';
S1MNEM [XMOVMS_19] := 'MOVMS.19 ';
S1MNEM [XMOVMS_20] := 'MOVMS.20 ';
S1MNEM [XMOVMS_21] := 'MOVMS.21 ';
S1MNEM [XMOVMS_22] := 'MOVMS.22 ';
S1MNEM [XMOVMS_23] := 'MOVMS.23 ';
S1MNEM [XMOVMS_24] := 'MOVMS.24 ';
S1MNEM [XMOVMS_25] := 'MOVMS.25 ';
S1MNEM [XMOVMS_26] := 'MOVMS.26 ';
S1MNEM [XMOVMS_27] := 'MOVMS.27 ';
S1MNEM [XMOVMS_28] := 'MOVMS.28 ';
S1MNEM [XMOVMS_29] := 'MOVMS.29 ';
S1MNEM [XMOVMS_30] := 'MOVMS.30 ';
S1MNEM [XMOVMS_31] := 'MOVMS.31 ';
S1MNEM [XMOVMS_32] := 'MOVMS.32 '; (*ALS*)
S1MNEM [XMULT_S] := 'MULT.S ';
S1MNEM [XMULT_D] := 'MULT.D ';
S1MNEM [XNEG_Q] := 'NEG.Q ';
S1MNEM [XNEG_H] := 'NEG.H ';
S1MNEM [XNEG_S] := 'NEG.S ';
S1MNEM [XNEG_D] := 'NEG.D ';
S1MNEM [XNOP] := 'NOP ';
S1MNEM [XOR_Q] := 'OR.Q ';
S1MNEM [XOR_D] := 'OR.D ';
S1MNEM [XQUO_S] := 'QUO.S ';
S1MNEM [XQUOV_S] := 'QUOV.S ';
S1MNEM [XQUO_D] := 'QUO.D ';
S1MNEM [XQUOV_D] := 'QUOV.D ';
S1MNEM [XREM_S] := 'REM.S ';
S1MNEM [XREMV_S] := 'REMV.S ';
S1MNEM [XREM_D] := 'REM.D ';
S1MNEM [XREMV_D] := 'REMV.D ';
S1MNEM [XRETSR] := 'RETSR ';
S1MNEM [XSHF_LF_D] := 'SHF.LF.D ';
S1MNEM [XSHFV_LF_D] := 'SHFV.LF.D ';
S1MNEM [XSHFA_LF_S] := 'SHFA.LF.S ';
S1MNEM [XSHFAV_LF_S] := 'SHFAV.LF.S ';
S1MNEM [XSKP_EQL_Q] := 'SKP.EQL.Q ';
S1MNEM [XSKP_NEQ_Q] := 'SKP.NEQ.Q ';
S1MNEM [XSKP_GEQ_Q] := 'SKP.GEQ.Q ';
S1MNEM [XSKP_GTR_Q] := 'SKP.GTR.Q ';
S1MNEM [XSKP_LEQ_Q] := 'SKP.LEQ.Q ';
S1MNEM [XSKP_LSS_Q] := 'SKP.LSS.Q ';
S1MNEM [XSKP_EQL_H] := 'SKP.EQL.H ';
S1MNEM [XSKP_NEQ_H] := 'SKP.NEQ.H ';
S1MNEM [XSKP_GEQ_H] := 'SKP.GEQ.H ';
S1MNEM [XSKP_GTR_H] := 'SKP.GTR.H ';
S1MNEM [XSKP_LEQ_H] := 'SKP.LEQ.H ';
S1MNEM [XSKP_LSS_H] := 'SKP.LSS.H ';
S1MNEM [XSKP_EQL_S] := 'SKP.EQL.S ';
S1MNEM [XSKP_NEQ_S] := 'SKP.NEQ.S ';
S1MNEM [XSKP_GEQ_S] := 'SKP.GEQ.S ';
S1MNEM [XSKP_GTR_S] := 'SKP.GTR.S ';
S1MNEM [XSKP_LEQ_S] := 'SKP.LEQ.S ';
S1MNEM [XSKP_LSS_S] := 'SKP.LSS.S ';
S1MNEM [XSKP_EQL_D] := 'SKP.EQL.D ';
S1MNEM [XSKP_NEQ_D] := 'SKP.NEQ.D ';
S1MNEM [XSKP_GEQ_D] := 'SKP.GEQ.D ';
S1MNEM [XSKP_GTR_D] := 'SKP.GTR.D ';
S1MNEM [XSKP_LEQ_D] := 'SKP.LEQ.D ';
S1MNEM [XSKP_LSS_D] := 'SKP.LSS.D ';
S1MNEM [XSKP_NON_Q] := 'SKP.NON.Q ';
S1MNEM [XSKP_NON_H] := 'SKP.NON.H ';
S1MNEM [XSKP_NON_S] := 'SKP.NON.S ';
S1MNEM [XSKP_NON_D] := 'SKP.NON.D ';
S1MNEM [XSKP_ANY_Q] := 'SKP.ANY.Q ';
S1MNEM [XSKP_ANY_H] := 'SKP.ANY.H ';
S1MNEM [XSKP_ANY_S] := 'SKP.ANY.S ';
S1MNEM [XSKP_ANY_D] := 'SKP.ANY.D ';
S1MNEM [XSLR_0] := 'SLR.0 ';
S1MNEM [XSLR_1] := 'SLR.1 ';
S1MNEM [XSLR_2] := 'SLR.2 ';
S1MNEM [XSLR_3] := 'SLR.3 ';
S1MNEM [XSLR_4] := 'SLR.4 ';
S1MNEM [XSLR_5] := 'SLR.5 ';
S1MNEM [XSLR_6] := 'SLR.6 ';
S1MNEM [XSLR_7] := 'SLR.7 ';
S1MNEM [XSLR_8] := 'SLR.8 ';
S1MNEM [XSLR_9] := 'SLR.9 ';
S1MNEM [XSLR_10] := 'SLR.10 ';
S1MNEM [XSLR_11] := 'SLR.11 ';
S1MNEM [XSLR_12] := 'SLR.12 ';
S1MNEM [XSLR_13] := 'SLR.13 ';
S1MNEM [XSLR_14] := 'SLR.14 ';
S1MNEM [XSLR_15] := 'SLR.15 ';
S1MNEM [XSLR_16] := 'SLR.16 ';
S1MNEM [XSLR_17] := 'SLR.17 ';
S1MNEM [XSLR_18] := 'SLR.18 ';
S1MNEM [XSLR_19] := 'SLR.19 ';
S1MNEM [XSLR_20] := 'SLR.20 ';
S1MNEM [XSLR_21] := 'SLR.21 ';
S1MNEM [XSLR_22] := 'SLR.22 ';
S1MNEM [XSLR_23] := 'SLR.23 ';
S1MNEM [XSLR_24] := 'SLR.24 ';
S1MNEM [XSLR_25] := 'SLR.25 ';
S1MNEM [XSLR_26] := 'SLR.26 ';
S1MNEM [XSLR_27] := 'SLR.27 ';
S1MNEM [XSLR_28] := 'SLR.28 ';
S1MNEM [XSLR_29] := 'SLR.29 ';
S1MNEM [XSLR_30] := 'SLR.30 ';
S1MNEM [XSLR_31] := 'SLR.31 ';
S1MNEM [XSLRADR_0] := 'SLRADR.0 ';
S1MNEM [XSLRADR_1] := 'SLRADR.1 ';
S1MNEM [XSLRADR_2] := 'SLRADR.2 ';
S1MNEM [XSLRADR_3] := 'SLRADR.3 ';
S1MNEM [XSLRADR_4] := 'SLRADR.4 ';
S1MNEM [XSLRADR_5] := 'SLRADR.5 ';
S1MNEM [XSLRADR_6] := 'SLRADR.6 ';
S1MNEM [XSLRADR_7] := 'SLRADR.7 ';
S1MNEM [XSLRADR_8] := 'SLRADR.8 ';
S1MNEM [XSLRADR_9] := 'SLRADR.9 ';
S1MNEM [XSLRADR_10] := 'SLRADR.10 ';
S1MNEM [XSLRADR_11] := 'SLRADR.11 ';
S1MNEM [XSLRADR_12] := 'SLRADR.12 ';
S1MNEM [XSLRADR_13] := 'SLRADR.13 ';
S1MNEM [XSLRADR_14] := 'SLRADR.14 ';
S1MNEM [XSLRADR_15] := 'SLRADR.15 ';
S1MNEM [XSLRADR_16] := 'SLRADR.16 ';
S1MNEM [XSLRADR_17] := 'SLRADR.17 ';
S1MNEM [XSLRADR_18] := 'SLRADR.18 ';
S1MNEM [XSLRADR_19] := 'SLRADR.19 ';
S1MNEM [XSLRADR_20] := 'SLRADR.20 ';
S1MNEM [XSLRADR_21] := 'SLRADR.21 ';
S1MNEM [XSLRADR_22] := 'SLRADR.22 ';
S1MNEM [XSLRADR_23] := 'SLRADR.23 ';
S1MNEM [XSLRADR_24] := 'SLRADR.24 ';
S1MNEM [XSLRADR_25] := 'SLRADR.25 ';
S1MNEM [XSLRADR_26] := 'SLRADR.26 ';
S1MNEM [XSLRADR_27] := 'SLRADR.27 ';
S1MNEM [XSLRADR_28] := 'SLRADR.28 ';
S1MNEM [XSLRADR_29] := 'SLRADR.29 ';
S1MNEM [XSLRADR_30] := 'SLRADR.30 ';
S1MNEM [XSLRADR_31] := 'SLRADR.31 ';
S1MNEM [XSUB_S] := 'SUB.S ';
S1MNEM [XSUBV_S] := 'SUBV.S ';
S1MNEM [XSUB_D] := 'SUB.D ';
S1MNEM [XSUBV_D] := 'SUBV.D ';
S1MNEM [XTRANS_Q_Q] := 'TRANS.Q.Q ';
S1MNEM [XTRANS_Q_H] := 'TRANS.Q.H ';
S1MNEM [XTRANS_H_Q] := 'TRANS.H.Q ';
S1MNEM [XTRANS_H_H] := 'TRANS.H.H ';
S1MNEM [XTRANS_Q_S] := 'TRANS.Q.S ';
S1MNEM [XTRANS_H_S] := 'TRANS.H.S ';
S1MNEM [XTRANS_S_Q] := 'TRANS.S.Q ';
S1MNEM [XTRANS_S_H] := 'TRANS.S.H ';
S1MNEM [XTRANS_S_S] := 'TRANS.S.S ';
S1MNEM [XTRANS_Q_D] := 'TRANS.Q.D ';
S1MNEM [XTRANS_H_D] := 'TRANS.H.D ';
S1MNEM [XTRANS_S_D] := 'TRANS.S.D ';
S1MNEM [XTRANS_D_Q] := 'TRANS.D.Q ';
S1MNEM [XTRANS_D_H] := 'TRANS.D.H ';
S1MNEM [XTRANS_D_S] := 'TRANS.D.S ';
S1MNEM [XTRANS_D_D] := 'TRANS.D.D ';
S1MNEM [XXOR_Q] := 'XOR.Q ';
" END S1MNEM MARKER FOR OPS.PAS "
end (*INIT4*);
(** INITIALIZE_CLASS: INIT5 **)
(**)
procedure INIT5;
begin
(* HARDOPCODEs for FAKEOPs should start at 4095 and work down. PBK*)
HARDOPCODE [XILLEGAL ] := 4095; (*PBK*)
HARDOPCODE [XPLOC ] := 4094; (*PBK*)
HARDOPCODE [XS1LOC ] := 4093; (*PBK*)
HARDOPCODE [XFREEREG ] := 4092; (*PBK*)
(* GENERATED SOPA OPCODES USING OPS.IN OF 11OCT78 2303 JBR *)
HARDOPCODE [XABS_Q ] := 1487;
HARDOPCODE [XABS_H ] := 1488;
HARDOPCODE [XABS_S ] := 1489;
HARDOPCODE [XABS_D ] := 1490;
HARDOPCODE [XADD_S ] := 12;
HARDOPCODE [XADD_D ] := 16;
HARDOPCODE [XADJSP_UP ] := 1830;
HARDOPCODE [XADJSP_DN ] := 1831;
HARDOPCODE [XALLOC_1 ] := 1666;
HARDOPCODE [XAND_Q ] := 736;
HARDOPCODE [XAND_D ] := 748;
HARDOPCODE [XAND_TC_D ] := 764;
HARDOPCODE [XAND_CT_D ] := 780;
HARDOPCODE [XBLCMP_EQL_Q ] := 1866;
HARDOPCODE [XBLCMP_NEQ_Q ] := 1878;
HARDOPCODE [XBLCMP_GEQ_Q ] := 1870;
HARDOPCODE [XBLCMP_GTR_Q ] := 1862;
HARDOPCODE [XBLCMP_LEQ_Q ] := 1882;
HARDOPCODE [XBLCMP_LSS_Q ] := 1874;
HARDOPCODE [XBLKMOV ] := 1886;
HARDOPCODE [XBTRP_B_Q ] := 1645;
HARDOPCODE [XBTRP_B_H ] := 1646;
HARDOPCODE [XBTRP_B_S ] := 1647;
HARDOPCODE [XBTRP_B_D ] := 1648;
HARDOPCODE [XBTRP_M1_Q ] := 1653;
HARDOPCODE [XBTRP_M1_H ] := 1654;
HARDOPCODE [XBTRP_M1_S ] := 1655;
HARDOPCODE [XBTRP_M1_D ] := 1656;
HARDOPCODE [XBTRP_0_Q ] := 1657;
HARDOPCODE [XBTRP_0_H ] := 1658;
HARDOPCODE [XBTRP_0_S ] := 1659;
HARDOPCODE [XBTRP_0_D ] := 1660;
HARDOPCODE [XBTRP_1_Q ] := 1661;
HARDOPCODE [XBTRP_1_H ] := 1662;
HARDOPCODE [XBTRP_1_S ] := 1663;
HARDOPCODE [XBTRP_1_D ] := 1664;
HARDOPCODE [XDEC_S ] := 1384;
HARDOPCODE [XFX_DM_S_S ] := 1433;
HARDOPCODE [XFX_DM_S_D ] := 1434;
HARDOPCODE [XFLOAT_S_Q ] := 1466;
HARDOPCODE [XFLOAT_S_H ] := 1467;
HARDOPCODE [XFLOAT_S_S ] := 1468;
HARDOPCODE [XFLOAT_S_D ] := 1469;
HARDOPCODE [XFADD_S ] := 412;
HARDOPCODE [XFADD_D ] := 416;
HARDOPCODE [XFSUB_S ] := 424;
HARDOPCODE [XFSUBV_S ] := 436;
HARDOPCODE [XFSUB_D ] := 428;
HARDOPCODE [XFSUBV_D ] := 440;
HARDOPCODE [XFMULT_S ] := 448;
HARDOPCODE [XFMULT_D ] := 452;
HARDOPCODE [XFDIV_S ] := 468;
HARDOPCODE [XFDIVV_S ] := 480;
HARDOPCODE [XFDIV_D ] := 472;
HARDOPCODE [XFDIVV_D ] := 484;
HARDOPCODE [XFTRANS_S_D ] := 1479;
HARDOPCODE [XFTRANS_D_S ] := 1481;
HARDOPCODE [XHALT ] := 1376; (*BNDTRPKLU*)
HARDOPCODE [XINC_S ] := 1380;
HARDOPCODE [XJMPA ] := 1296;
HARDOPCODE [XJMPZ_EQL_Q ] := 1256;
HARDOPCODE [XJSR ] := 1350;
HARDOPCODE [XMOV_A ] := 1639;
HARDOPCODE [XMOV_Q_Q ] := 1491;
HARDOPCODE [XMOV_Q_H ] := 1492;
HARDOPCODE [XMOV_H_Q ] := 1495;
HARDOPCODE [XMOV_H_H ] := 1496;
HARDOPCODE [XMOV_Q_S ] := 1493;
HARDOPCODE [XMOV_H_S ] := 1497;
HARDOPCODE [XMOV_S_Q ] := 1499;
HARDOPCODE [XMOV_S_H ] := 1500;
HARDOPCODE [XMOV_S_S ] := 1501;
HARDOPCODE [XMOV_Q_D ] := 1494;
HARDOPCODE [XMOV_H_D ] := 1498;
HARDOPCODE [XMOV_S_D ] := 1502;
HARDOPCODE [XMOV_D_Q ] := 1503;
HARDOPCODE [XMOV_D_H ] := 1504;
HARDOPCODE [XMOV_D_S ] := 1505;
HARDOPCODE [XMOV_D_D ] := 1506;
HARDOPCODE [XMOVMQ_2 ] := 1507;
HARDOPCODE [XMOVMQ_3 ] := 1508;
HARDOPCODE [XMOVMQ_4 ] := 1509;
HARDOPCODE [XMOVMQ_5 ] := 1510;
HARDOPCODE [XMOVMQ_6 ] := 1511;
HARDOPCODE [XMOVMQ_7 ] := 1512;
HARDOPCODE [XMOVMQ_8 ] := 1513;
HARDOPCODE [XMOVMQ_9 ] := 1514;
HARDOPCODE [XMOVMQ_10 ] := 1515;
HARDOPCODE [XMOVMQ_11 ] := 1516;
HARDOPCODE [XMOVMQ_12 ] := 1517;
HARDOPCODE [XMOVMQ_13 ] := 1518;
HARDOPCODE [XMOVMQ_14 ] := 1519;
HARDOPCODE [XMOVMQ_15 ] := 1520;
HARDOPCODE [XMOVMQ_16 ] := 1521;
HARDOPCODE [XMOVMQ_17 ] := 1522;
HARDOPCODE [XMOVMQ_18 ] := 1523;
HARDOPCODE [XMOVMQ_19 ] := 1524;
HARDOPCODE [XMOVMQ_20 ] := 1525;
HARDOPCODE [XMOVMQ_21 ] := 1526;
HARDOPCODE [XMOVMQ_22 ] := 1527;
HARDOPCODE [XMOVMQ_23 ] := 1528;
HARDOPCODE [XMOVMQ_24 ] := 1529;
HARDOPCODE [XMOVMQ_25 ] := 1530;
HARDOPCODE [XMOVMQ_26 ] := 1531;
HARDOPCODE [XMOVMQ_27 ] := 1532;
HARDOPCODE [XMOVMQ_28 ] := 1533;
HARDOPCODE [XMOVMQ_29 ] := 1534;
HARDOPCODE [XMOVMQ_30 ] := 1535;
HARDOPCODE [XMOVMQ_31 ] := 1536;
HARDOPCODE [XMOVMQ_32 ] := 1537;
HARDOPCODE [XMOVMQ_64 ] := 1538;
HARDOPCODE [XMOVMQ_128 ] := 1539;
HARDOPCODE [XMOVMS_2 ] := 1507;
HARDOPCODE [XMOVMS_3 ] := 1508;
HARDOPCODE [XMOVMS_4 ] := 1509;
HARDOPCODE [XMOVMS_5 ] := 1510;
HARDOPCODE [XMOVMS_6 ] := 1511;
HARDOPCODE [XMOVMS_7 ] := 1512;
HARDOPCODE [XMOVMS_8 ] := 1513;
HARDOPCODE [XMOVMS_9 ] := 1514;
HARDOPCODE [XMOVMS_10 ] := 1515;
HARDOPCODE [XMOVMS_11 ] := 1516;
HARDOPCODE [XMOVMS_12 ] := 1517;
HARDOPCODE [XMOVMS_13 ] := 1518;
HARDOPCODE [XMOVMS_14 ] := 1519;
HARDOPCODE [XMOVMS_15 ] := 1520;
HARDOPCODE [XMOVMS_16 ] := 1521;
HARDOPCODE [XMOVMS_17 ] := 1522;
HARDOPCODE [XMOVMS_18 ] := 1523;
HARDOPCODE [XMOVMS_19 ] := 1524;
HARDOPCODE [XMOVMS_20 ] := 1525;
HARDOPCODE [XMOVMS_21 ] := 1526;
HARDOPCODE [XMOVMS_22 ] := 1527;
HARDOPCODE [XMOVMS_23 ] := 1528;
HARDOPCODE [XMOVMS_24 ] := 1529;
HARDOPCODE [XMOVMS_25 ] := 1530;
HARDOPCODE [XMOVMS_26 ] := 1531;
HARDOPCODE [XMOVMS_27 ] := 1532;
HARDOPCODE [XMOVMS_28 ] := 1533;
HARDOPCODE [XMOVMS_29 ] := 1534;
HARDOPCODE [XMOVMS_30 ] := 1535;
HARDOPCODE [XMOVMS_31 ] := 1536;
HARDOPCODE [XMOVMS_32 ] := 1537;
HARDOPCODE [XMULT_S ] := 108;
HARDOPCODE [XMULT_D ] := 112;
HARDOPCODE [XNEG_Q ] := 1483;
HARDOPCODE [XNEG_H ] := 1484;
HARDOPCODE [XNEG_S ] := 1485;
HARDOPCODE [XNEG_D ] := 1486;
HARDOPCODE [XNOP ] := 1939;
HARDOPCODE [XOR_Q ] := 784;
HARDOPCODE [XOR_D ] := 796;
HARDOPCODE [XQUO_S ] := 136;
HARDOPCODE [XQUOV_S ] := 152;
HARDOPCODE [XQUO_D ] := 140;
HARDOPCODE [XQUOV_D ] := 156;
HARDOPCODE [XREM_S ] := 248;
HARDOPCODE [XREMV_S ] := 264;
HARDOPCODE [XREM_D ] := 252;
HARDOPCODE [XREMV_D ] := 268;
HARDOPCODE [XRETSR ] := 1698;
HARDOPCODE [XSHF_LF_D ] := 908;
HARDOPCODE [XSHFV_LF_D ] := 940;
HARDOPCODE [XSHFA_LF_S ] := 1016;
HARDOPCODE [XSHFAV_LF_S ] := 1048;
HARDOPCODE [XSKP_EQL_Q ] := 2112;
HARDOPCODE [XSKP_NEQ_Q ] := 2304;
HARDOPCODE [XSKP_GEQ_Q ] := 2176;
HARDOPCODE [XSKP_GTR_Q ] := 2048;
HARDOPCODE [XSKP_LEQ_Q ] := 2368;
HARDOPCODE [XSKP_LSS_Q ] := 2240;
HARDOPCODE [XSKP_EQL_H ] := 2128;
HARDOPCODE [XSKP_NEQ_H ] := 2320;
HARDOPCODE [XSKP_GEQ_H ] := 2192;
HARDOPCODE [XSKP_GTR_H ] := 2064;
HARDOPCODE [XSKP_LEQ_H ] := 2384;
HARDOPCODE [XSKP_LSS_H ] := 2256;
HARDOPCODE [XSKP_EQL_S ] := 2144;
HARDOPCODE [XSKP_NEQ_S ] := 2336;
HARDOPCODE [XSKP_GEQ_S ] := 2208;
HARDOPCODE [XSKP_GTR_S ] := 2080;
HARDOPCODE [XSKP_LEQ_S ] := 2400;
HARDOPCODE [XSKP_LSS_S ] := 2272;
HARDOPCODE [XSKP_EQL_D ] := 2160;
HARDOPCODE [XSKP_NEQ_D ] := 2352;
HARDOPCODE [XSKP_GEQ_D ] := 2224;
HARDOPCODE [XSKP_GTR_D ] := 2096;
HARDOPCODE [XSKP_LEQ_D ] := 2416;
HARDOPCODE [XSKP_LSS_D ] := 2288;
HARDOPCODE [XSKP_NON_Q ] := 2432;
HARDOPCODE [XSKP_NON_H ] := 2448;
HARDOPCODE [XSKP_NON_S ] := 2464;
HARDOPCODE [XSKP_NON_D ] := 2480;
HARDOPCODE [XSKP_ANY_Q ] := 2624;
HARDOPCODE [XSKP_ANY_H ] := 2640;
HARDOPCODE [XSKP_ANY_S ] := 2656;
HARDOPCODE [XSKP_ANY_D ] := 2672;
HARDOPCODE [XSLR_0 ] := 1575;
HARDOPCODE [XSLR_1 ] := 1576;
HARDOPCODE [XSLR_2 ] := 1577;
HARDOPCODE [XSLR_3 ] := 1578;
HARDOPCODE [XSLR_4 ] := 1579;
HARDOPCODE [XSLR_5 ] := 1580;
HARDOPCODE [XSLR_6 ] := 1581;
HARDOPCODE [XSLR_7 ] := 1582;
HARDOPCODE [XSLR_8 ] := 1583;
HARDOPCODE [XSLR_9 ] := 1584;
HARDOPCODE [XSLR_10 ] := 1585;
HARDOPCODE [XSLR_11 ] := 1586;
HARDOPCODE [XSLR_12 ] := 1587;
HARDOPCODE [XSLR_13 ] := 1588;
HARDOPCODE [XSLR_14 ] := 1589;
HARDOPCODE [XSLR_15 ] := 1590;
HARDOPCODE [XSLR_16 ] := 1591;
HARDOPCODE [XSLR_17 ] := 1592;
HARDOPCODE [XSLR_18 ] := 1593;
HARDOPCODE [XSLR_19 ] := 1594;
HARDOPCODE [XSLR_20 ] := 1595;
HARDOPCODE [XSLR_21 ] := 1596;
HARDOPCODE [XSLR_22 ] := 1597;
HARDOPCODE [XSLR_23 ] := 1598;
HARDOPCODE [XSLR_24 ] := 1599;
HARDOPCODE [XSLR_25 ] := 1600;
HARDOPCODE [XSLR_26 ] := 1601;
HARDOPCODE [XSLR_27 ] := 1602;
HARDOPCODE [XSLR_28 ] := 1603;
HARDOPCODE [XSLR_29 ] := 1604;
HARDOPCODE [XSLR_30 ] := 1605;
HARDOPCODE [XSLR_31 ] := 1606;
HARDOPCODE [XSLRADR_0 ] := 1607;
HARDOPCODE [XSLRADR_1 ] := 1608;
HARDOPCODE [XSLRADR_2 ] := 1609;
HARDOPCODE [XSLRADR_3 ] := 1610;
HARDOPCODE [XSLRADR_4 ] := 1611;
HARDOPCODE [XSLRADR_5 ] := 1612;
HARDOPCODE [XSLRADR_6 ] := 1613;
HARDOPCODE [XSLRADR_7 ] := 1614;
HARDOPCODE [XSLRADR_8 ] := 1615;
HARDOPCODE [XSLRADR_9 ] := 1616;
HARDOPCODE [XSLRADR_10 ] := 1617;
HARDOPCODE [XSLRADR_11 ] := 1618;
HARDOPCODE [XSLRADR_12 ] := 1619;
HARDOPCODE [XSLRADR_13 ] := 1620;
HARDOPCODE [XSLRADR_14 ] := 1621;
HARDOPCODE [XSLRADR_15 ] := 1622;
HARDOPCODE [XSLRADR_16 ] := 1623;
HARDOPCODE [XSLRADR_17 ] := 1624;
HARDOPCODE [XSLRADR_18 ] := 1625;
HARDOPCODE [XSLRADR_19 ] := 1626;
HARDOPCODE [XSLRADR_20 ] := 1627;
HARDOPCODE [XSLRADR_21 ] := 1628;
HARDOPCODE [XSLRADR_22 ] := 1629;
HARDOPCODE [XSLRADR_23 ] := 1630;
HARDOPCODE [XSLRADR_24 ] := 1631;
HARDOPCODE [XSLRADR_25 ] := 1632;
HARDOPCODE [XSLRADR_26 ] := 1633;
HARDOPCODE [XSLRADR_27 ] := 1634;
HARDOPCODE [XSLRADR_28 ] := 1635;
HARDOPCODE [XSLRADR_29 ] := 1636;
HARDOPCODE [XSLRADR_30 ] := 1637;
HARDOPCODE [XSLRADR_31 ] := 1638;
HARDOPCODE [XSUB_S ] := 44;
HARDOPCODE [XSUBV_S ] := 60;
HARDOPCODE [XSUB_D ] := 48;
HARDOPCODE [XSUBV_D ] := 64;
HARDOPCODE [XTRANS_Q_Q ] := 1386;
HARDOPCODE [XTRANS_Q_H ] := 1387;
HARDOPCODE [XTRANS_H_Q ] := 1390;
HARDOPCODE [XTRANS_H_H ] := 1391;
HARDOPCODE [XTRANS_Q_S ] := 1388;
HARDOPCODE [XTRANS_H_S ] := 1392;
HARDOPCODE [XTRANS_S_Q ] := 1394;
HARDOPCODE [XTRANS_S_H ] := 1395;
HARDOPCODE [XTRANS_S_S ] := 1396;
HARDOPCODE [XTRANS_Q_D ] := 1389;
HARDOPCODE [XTRANS_H_D ] := 1393;
HARDOPCODE [XTRANS_S_D ] := 1397;
HARDOPCODE [XTRANS_D_Q ] := 1398;
HARDOPCODE [XTRANS_D_H ] := 1399;
HARDOPCODE [XTRANS_D_S ] := 1400;
HARDOPCODE [XTRANS_D_D ] := 1401;
HARDOPCODE [XXOR_Q ] := 864;
end (*INIT5*);
(** INITIALIZE_CLASS: INIT6 **)
(**)
procedure INIT6;
begin
INVERSE_SKIP [XSKP_EQL_Q] := XSKP_NEQ_Q;
INVERSE_SKIP [XSKP_NEQ_Q] := XSKP_EQL_Q;
INVERSE_SKIP [XSKP_GEQ_Q] := XSKP_LSS_Q;
INVERSE_SKIP [XSKP_LSS_Q] := XSKP_GEQ_Q;
INVERSE_SKIP [XSKP_GTR_Q] := XSKP_LEQ_Q;
INVERSE_SKIP [XSKP_LEQ_Q] := XSKP_GTR_Q;
INVERSE_SKIP [XSKP_EQL_H] := XSKP_NEQ_H;
INVERSE_SKIP [XSKP_NEQ_H] := XSKP_EQL_H;
INVERSE_SKIP [XSKP_GEQ_H] := XSKP_LSS_H;
INVERSE_SKIP [XSKP_LSS_H] := XSKP_GEQ_H;
INVERSE_SKIP [XSKP_GTR_H] := XSKP_LEQ_H;
INVERSE_SKIP [XSKP_LEQ_H] := XSKP_GTR_H;
INVERSE_SKIP [XSKP_EQL_S] := XSKP_NEQ_S;
INVERSE_SKIP [XSKP_NEQ_S] := XSKP_EQL_S;
INVERSE_SKIP [XSKP_GEQ_S] := XSKP_LSS_S;
INVERSE_SKIP [XSKP_LSS_S] := XSKP_GEQ_S;
INVERSE_SKIP [XSKP_GTR_S] := XSKP_LEQ_S;
INVERSE_SKIP [XSKP_LEQ_S] := XSKP_GTR_S;
INVERSE_SKIP [XSKP_EQL_D] := XSKP_NEQ_D;
INVERSE_SKIP [XSKP_NEQ_D] := XSKP_EQL_D;
INVERSE_SKIP [XSKP_GEQ_D] := XSKP_LSS_D;
INVERSE_SKIP [XSKP_LSS_D] := XSKP_GEQ_D;
INVERSE_SKIP [XSKP_GTR_D] := XSKP_LEQ_D;
INVERSE_SKIP [XSKP_LEQ_D] := XSKP_GTR_D;
INVERSE_SKIP [XSKP_NON_Q] := XSKP_ANY_Q;
INVERSE_SKIP [XSKP_NON_H] := XSKP_ANY_H;
INVERSE_SKIP [XSKP_NON_S] := XSKP_ANY_S;
INVERSE_SKIP [XSKP_NON_D] := XSKP_ANY_D;
INVERSE_SKIP [XSKP_ANY_Q] := XSKP_NON_Q;
INVERSE_SKIP [XSKP_ANY_H] := XSKP_NON_H;
INVERSE_SKIP [XSKP_ANY_S] := XSKP_NON_S;
INVERSE_SKIP [XSKP_ANY_D] := XSKP_NON_D;
for S1OP := FIRSTS1OP to LASTS1OP do
begin
case OPFORMAT[S1OP] of
VFAKEOP, VXOP : N := 1;
VTOP : N := TWOEXP[T_LEN];
VJOP : N := TWOEXP[PR_LEN];
VSOP : N := TWOEXP[SKP_LEN];
end (*case*);
if not ( HARDOPCODE[S1OP] mod N = 0) then ASSERTFAIL('INITIALIZ001');
for I := HARDOPCODE[S1OP] to (HARDOPCODE[S1OP]+N-1) do
SOFTOPCODE[I] := S1OP;
end (*for S1OP := *);
for S1OP := FIRSTS1OP to LASTS1OP do S1OP_CNT[S1OP] := 0; (*LCW*)
WORD_CNT := 0; (*LCW*)
GETFIELD_CNT := 0; (*PTZ*)
INSTR_WDS_REMOVED := 0; (*PTZ*)
J_TO_J_CNT := 0; (*PBK*)
JMPAS_REMOVED_FROM_SKIPS := 0; (*PTZ*)
MOVS_COLLAPSED := 0; (*PTZ*)
TR_PCODE := false;
TR_S1CODE := false;
TR_STACK := false;
TR_MST := false;
TR_NEST := false;
TR_SIMP := false;
MAINCODE := EMPTYCODELIST;
NEWINSTREC := nil;
TOP := BOT-1;
MSTTOP := 0;
DEBUG := false;
ASM := false;
ERRORCNT := 0;
MAXLVLUSED := 0;
end (*INIT6*);
(** INITIALIZE_CLASS: INIT7 **)
(**)
procedure INIT7; (*PBK*)
var S1OP : S1OPCODE;
begin
(*Right now COLLAPSIBLE_OP[S1OP] = false iff DEST_PRECISION[S1OP]
= S1ILLEGAL. Someone ought to monitor this & remove COLLAPSIBLE_OP
if the situation persists for a long time. 9/24/78 PTZ*)
for S1OP := FIRSTS1OP to LASTS1OP do
COLLAPSIBLE_OP [S1OP] := false;
COLLAPSIBLE_OP [XABS_Q] := true;
COLLAPSIBLE_OP [XABS_H] := true;
COLLAPSIBLE_OP [XABS_S] := true;
COLLAPSIBLE_OP [XABS_D] := true;
COLLAPSIBLE_OP [XADD_S] := true;
COLLAPSIBLE_OP [XADD_D] := true;
COLLAPSIBLE_OP [XAND_Q] := true;
COLLAPSIBLE_OP [XAND_D] := true;
COLLAPSIBLE_OP [XAND_TC_D] := true;
COLLAPSIBLE_OP [XAND_CT_D] := true;
COLLAPSIBLE_OP [XDEC_S] := true;
COLLAPSIBLE_OP [XFX_DM_S_S] := true;
COLLAPSIBLE_OP [XFX_DM_S_D] := true;
COLLAPSIBLE_OP [XFLOAT_S_Q] := true;
COLLAPSIBLE_OP [XFLOAT_S_H] := true;
COLLAPSIBLE_OP [XFLOAT_S_S] := true;
COLLAPSIBLE_OP [XFLOAT_S_D] := true;
COLLAPSIBLE_OP [XFADD_S] := true;
COLLAPSIBLE_OP [XFADD_D] := true;
COLLAPSIBLE_OP [XFSUB_S] := true;
COLLAPSIBLE_OP [XFSUBV_S] := true;
COLLAPSIBLE_OP [XFSUB_D] := true;
COLLAPSIBLE_OP [XFSUBV_D] := true;
COLLAPSIBLE_OP [XFMULT_S] := true;
COLLAPSIBLE_OP [XFMULT_D] := true;
COLLAPSIBLE_OP [XFDIV_S] := true;
COLLAPSIBLE_OP [XFDIVV_S] := true;
COLLAPSIBLE_OP [XFDIV_D] := true;
COLLAPSIBLE_OP [XFDIVV_D] := true;
COLLAPSIBLE_OP [XFTRANS_S_D] := true;
COLLAPSIBLE_OP [XFTRANS_D_S] := true;
COLLAPSIBLE_OP [XINC_S] := true;
COLLAPSIBLE_OP [XMOV_A] := true;
COLLAPSIBLE_OP [XMOV_Q_Q] := true;
COLLAPSIBLE_OP [XMOV_Q_H] := true;
COLLAPSIBLE_OP [XMOV_H_Q] := true;
COLLAPSIBLE_OP [XMOV_H_H] := true;
COLLAPSIBLE_OP [XMOV_Q_S] := true;
COLLAPSIBLE_OP [XMOV_H_S] := true;
COLLAPSIBLE_OP [XMOV_S_Q] := true;
COLLAPSIBLE_OP [XMOV_S_H] := true;
COLLAPSIBLE_OP [XMOV_S_S] := true;
COLLAPSIBLE_OP [XMOV_Q_D] := true;
COLLAPSIBLE_OP [XMOV_H_D] := true;
COLLAPSIBLE_OP [XMOV_S_D] := true;
COLLAPSIBLE_OP [XMOV_D_Q] := true;
COLLAPSIBLE_OP [XMOV_D_H] := true;
COLLAPSIBLE_OP [XMOV_D_S] := true;
COLLAPSIBLE_OP [XMOV_D_D] := true;
COLLAPSIBLE_OP [XMULT_S] := true;
COLLAPSIBLE_OP [XMULT_D] := true;
COLLAPSIBLE_OP [XNEG_Q] := true;
COLLAPSIBLE_OP [XNEG_H] := true;
COLLAPSIBLE_OP [XNEG_S] := true;
COLLAPSIBLE_OP [XNEG_D] := true;
COLLAPSIBLE_OP [XOR_Q] := true;
COLLAPSIBLE_OP [XOR_D] := true;
COLLAPSIBLE_OP [XQUO_S] := true;
COLLAPSIBLE_OP [XQUOV_S] := true;
COLLAPSIBLE_OP [XQUO_D] := true;
COLLAPSIBLE_OP [XQUOV_D] := true;
COLLAPSIBLE_OP [XREM_S] := true;
COLLAPSIBLE_OP [XREMV_S] := true;
COLLAPSIBLE_OP [XREM_D] := true;
COLLAPSIBLE_OP [XREMV_D] := true;
COLLAPSIBLE_OP [XSHF_LF_D] := true;
COLLAPSIBLE_OP [XSHFV_LF_D] := true;
COLLAPSIBLE_OP [XSHFA_LF_S] := true;
COLLAPSIBLE_OP [XSHFAV_LF_S] := true;
COLLAPSIBLE_OP [XSUB_S] := true;
COLLAPSIBLE_OP [XSUBV_S] := true;
COLLAPSIBLE_OP [XSUB_D] := true;
COLLAPSIBLE_OP [XSUBV_D] := true;
COLLAPSIBLE_OP [XTRANS_Q_Q] := true;
COLLAPSIBLE_OP [XTRANS_Q_H] := true;
COLLAPSIBLE_OP [XTRANS_H_Q] := true;
COLLAPSIBLE_OP [XTRANS_H_H] := true;
COLLAPSIBLE_OP [XTRANS_Q_S] := true;
COLLAPSIBLE_OP [XTRANS_H_S] := true;
COLLAPSIBLE_OP [XTRANS_S_Q] := true;
COLLAPSIBLE_OP [XTRANS_S_H] := true;
COLLAPSIBLE_OP [XTRANS_S_S] := true;
COLLAPSIBLE_OP [XTRANS_Q_D] := true;
COLLAPSIBLE_OP [XTRANS_H_D] := true;
COLLAPSIBLE_OP [XTRANS_S_D] := true;
COLLAPSIBLE_OP [XTRANS_D_Q] := true;
COLLAPSIBLE_OP [XTRANS_D_H] := true;
COLLAPSIBLE_OP [XTRANS_D_S] := true;
COLLAPSIBLE_OP [XTRANS_D_D] := true;
COLLAPSIBLE_OP [XXOR_Q] := true;
for S1OP := FIRSTS1OP to LASTS1OP do
DEST_PRECISION [S1OP] := S1ILLEGAL;
DEST_PRECISION [XABS_Q] := S1Q;
DEST_PRECISION [XABS_H] := S1H;
DEST_PRECISION [XABS_S] := S1S;
DEST_PRECISION [XABS_D] := S1D;
DEST_PRECISION [XADD_S] := S1S;
DEST_PRECISION [XADD_D] := S1D;
DEST_PRECISION [XAND_Q] := S1Q;
DEST_PRECISION [XAND_D] := S1D;
DEST_PRECISION [XAND_TC_D] := S1D;
DEST_PRECISION [XAND_CT_D] := S1D;
DEST_PRECISION [XDEC_S] := S1S;
DEST_PRECISION [XFX_DM_S_S] := S1S;
DEST_PRECISION [XFX_DM_S_D] := S1S;
DEST_PRECISION [XFLOAT_S_Q] := S1S;
DEST_PRECISION [XFLOAT_S_H] := S1S;
DEST_PRECISION [XFLOAT_S_S] := S1S;
DEST_PRECISION [XFLOAT_S_D] := S1S;
DEST_PRECISION [XFADD_S] := S1S;
DEST_PRECISION [XFADD_D] := S1D;
DEST_PRECISION [XFSUB_S] := S1S;
DEST_PRECISION [XFSUBV_S] := S1S;
DEST_PRECISION [XFSUB_D] := S1D;
DEST_PRECISION [XFSUBV_D] := S1D;
DEST_PRECISION [XFMULT_S] := S1S;
DEST_PRECISION [XFMULT_D] := S1D;
DEST_PRECISION [XFDIV_S] := S1S;
DEST_PRECISION [XFDIVV_S] := S1S;
DEST_PRECISION [XFDIV_D] := S1D;
DEST_PRECISION [XFDIVV_D] := S1D;
DEST_PRECISION [XFTRANS_S_D] := S1S;
DEST_PRECISION [XFTRANS_D_S] := S1D;
DEST_PRECISION [XINC_S] := S1S;
DEST_PRECISION [XMOV_A] := S1S;
DEST_PRECISION [XMOV_Q_Q] := S1Q;
DEST_PRECISION [XMOV_Q_H] := S1Q;
DEST_PRECISION [XMOV_H_Q] := S1H;
DEST_PRECISION [XMOV_H_H] := S1H;
DEST_PRECISION [XMOV_Q_S] := S1Q;
DEST_PRECISION [XMOV_H_S] := S1H;
DEST_PRECISION [XMOV_S_Q] := S1S;
DEST_PRECISION [XMOV_S_H] := S1S;
DEST_PRECISION [XMOV_S_S] := S1S;
DEST_PRECISION [XMOV_Q_D] := S1Q;
DEST_PRECISION [XMOV_H_D] := S1H;
DEST_PRECISION [XMOV_S_D] := S1S;
DEST_PRECISION [XMOV_D_Q] := S1D;
DEST_PRECISION [XMOV_D_H] := S1D;
DEST_PRECISION [XMOV_D_S] := S1D;
DEST_PRECISION [XMOV_D_D] := S1D;
DEST_PRECISION [XMULT_S] := S1S;
DEST_PRECISION [XMULT_D] := S1D;
DEST_PRECISION [XNEG_Q] := S1Q;
DEST_PRECISION [XNEG_H] := S1H;
DEST_PRECISION [XNEG_S] := S1S;
DEST_PRECISION [XNEG_D] := S1D;
DEST_PRECISION [XOR_Q] := S1Q;
DEST_PRECISION [XOR_D] := S1D;
DEST_PRECISION [XQUO_S] := S1S;
DEST_PRECISION [XQUOV_S] := S1S;
DEST_PRECISION [XQUO_D] := S1D;
DEST_PRECISION [XQUOV_D] := S1D;
DEST_PRECISION [XREM_S] := S1S;
DEST_PRECISION [XREMV_S] := S1S;
DEST_PRECISION [XREM_D] := S1D;
DEST_PRECISION [XREMV_D] := S1D;
DEST_PRECISION [XSHF_LF_D] := S1D;
DEST_PRECISION [XSHFV_LF_D] := S1D;
DEST_PRECISION [XSHFA_LF_S] := S1S;
DEST_PRECISION [XSHFAV_LF_S] := S1S;
DEST_PRECISION [XSUB_S] := S1S;
DEST_PRECISION [XSUBV_S] := S1S;
DEST_PRECISION [XSUB_D] := S1D;
DEST_PRECISION [XSUBV_D] := S1D;
DEST_PRECISION [XTRANS_Q_Q] := S1Q;
DEST_PRECISION [XTRANS_Q_H] := S1Q;
DEST_PRECISION [XTRANS_H_Q] := S1H;
DEST_PRECISION [XTRANS_H_H] := S1H;
DEST_PRECISION [XTRANS_Q_S] := S1Q;
DEST_PRECISION [XTRANS_H_S] := S1H;
DEST_PRECISION [XTRANS_S_Q] := S1S;
DEST_PRECISION [XTRANS_S_H] := S1S;
DEST_PRECISION [XTRANS_S_S] := S1S;
DEST_PRECISION [XTRANS_Q_D] := S1Q;
DEST_PRECISION [XTRANS_H_D] := S1H;
DEST_PRECISION [XTRANS_S_D] := S1S;
DEST_PRECISION [XTRANS_D_Q] := S1D;
DEST_PRECISION [XTRANS_D_H] := S1D;
DEST_PRECISION [XTRANS_D_S] := S1D;
DEST_PRECISION [XTRANS_D_D] := S1D;
DEST_PRECISION [XXOR_Q] := S1Q;
end (*INIT7*);
(** INITIALIZE_CLASS: **)
(**)
begin (*INITIALIZE*)
INIT1;
INIT2;
INIT3;
INIT4;
INIT5;
INIT6;
INIT7; (*PBK*)
end (*INITIALIZE*);
(** MAIN_PROGRAM: **)
(**)
begin (*Main Program.*)
ASSERTCOUNT := 0;
INITIALIZE;
TIMER := CLOCK; (*X10S1*)
(*TIMER := CLOCK(1); *) (*X10S1*)
repeat
OLDINSTREC := NEWINSTREC;
OLDTOP := TOP;
OLDMSTTOP := MSTTOP;
READNXTINST;
if TR_PCODE then PRINTNXTINST;
ASMNXTINST;
if TR_S1CODE and (OLDINSTREC <> NEWINSTREC) then
begin
WRITELN (OUTPUT, ' Instruction(s) emitted:');
if OLDINSTREC = nil then
OLDINSTREC := MAINCODE.FIRST;
while OLDINSTREC <> nil do
begin
UNKNOWN_LOC := 0;
DISASSEMBLE (UNKNOWN_LOC, OLDINSTREC);
OLDINSTREC := NEXT_INSTRUCTION(OLDINSTREC);
end;
end;
if TR_STACK then
begin
if OLDTOP < TOP then
WRITELN (OUTPUT, ' Stack pushed. New top is ',
TOP : FLDW(TOP) )
else if OLDTOP > TOP then
WRITELN (OUTPUT, ' Stack popped. New top is ',
TOP : FLDW(TOP) )
else if TOP >= BOT then
WRITELN (OUTPUT, ' Stack top is ')
else
WRITELN (OUTPUT, ' Stack is empty.');
if TOP >= BOT then PRINTDATUM (TOP);
end;
if TR_MST and (MSTTOP <> OLDMSTTOP) then
begin
if OLDMSTTOP < MSTTOP then
WRITELN (OUTPUT, ' MST stack pushed. New top is ',
MSTTOP : FLDW(MSTTOP) )
else if OLDMSTTOP > MSTTOP then
WRITELN (OUTPUT, ' MST stack popped. New top is ',
MSTTOP : FLDW(MSTTOP) );
PRINT_MSTENTRY (MSTTOP);
end;
until OPC = PSTP;
WRITELN (OUTPUT,'************************** ;START OF STATISTICS'); (*LCW*)
WRITELN (OUTPUT); (*PBK*)
WRITELN (OUTPUT,' PEEPHOLE OPTIMIZER STATISTICS:'); (*PBK*)
WRITELN (OUTPUT); (*PBK*)
WRITELN (OUTPUT,' ',J_TO_J_CNT:7,' JMPAS CHAINED'); (*PBK*)
WRITELN (OUTPUT,' ',JMPAS_REMOVED_FROM_SKIPS:7,' JMPAS REMOVED FROM SKIPS');(*PTZ*)
WRITELN (OUTPUT,' ',MOVS_COLLAPSED:7,' MOVS COLLAPSED'); (*PTZ*)
WRITELN (OUTPUT); (*PTZ*)
WRITELN (OUTPUT,' ',INSTR_WDS_REMOVED:7,' TOTAL WORDS REMOVED'); (*PTZ*)
WRITELN (OUTPUT); (*LCW*)
WRITELN (OUTPUT,' INSTRUCTION COUNTS:'); (*LCW*)
WRITELN (OUTPUT); (*LCW*)
S1OP_TOT := 0; (*LCW*)
for S1OP := FIRSTS1OP to LASTS1OP do (*LCW*)
if OPFORMAT[S1OP] <> VFAKEOP then (*LCW*)
begin (*LCW*)
S1OP_TOT := S1OP_TOT + S1OP_CNT[S1OP]; (*LCW*)
if S1OP_CNT[S1OP] <> 0 (*LCW*)
then WRITELN (OUTPUT,' ',S1OP_CNT[S1OP]:7,' ',S1MNEM[S1OP]); (*LCW*)
end; (*LCW*)
WRITELN (OUTPUT); (*LCW*)
WRITELN (OUTPUT,' ',S1OP_TOT:7,' TOTAL INSTRUCTIONS'); (*LCW*)
WRITELN (OUTPUT); (*LCW*)
WRITELN (OUTPUT,' ',WORD_CNT:7,' TXT WORDS OUTPUT TO LOADER FILE'); (*LCW*)
TIMER := ( CLOCK - TIMER ) div 10; (*X10S1*)
(*TIMER := ( CLOCK(1) - TIMER ) div 10; *) (*X10S1*)
WRITELN(OUTPUT);
WRITE (OUTPUT, ' ****' : 14);
if ERRORCNT > 0 then WRITE (OUTPUT, ERRORCNT : 5)
else WRITE (OUTPUT, 'NO' : 5);
WRITELN (OUTPUT, ' ASSEMBLY ERROR(S) DETECTED,',
TIMER div 100 : 3, '.', TIMER mod 100 : 2,
' SECONDS in P-CODE ASSEMBLY.' );
if ERRORCNT <> 0 then ERREXIT (ERRORCNT);
end (*Main Program*).